Excel VBA - 将单元格值设置为与所有非空白单元格相邻的变量

Question

我有多个报告需要按照特定步骤编译成一个主文件，然后在新数据的左侧添加一个日期。需要遵循的步骤是：

1. 在目录中打开一个文件
2. 根据文件名设置一个变量，以便在后面的步骤中使用（我为此使用了 InputBox 函数）
3. 从该文件复制所有包含 A 列数据的单元格
4. 将单元格数据粘贴到我的主文件 B 列的第一个空白单元格中
5. 如果 B 列中有数据，并且 A 列中的相邻单元格为空白，则将该单元格的值更改为步骤 2 中选择的变量
6. 关闭文件并打开目录中的下一个文件

所以基本上，它需要打开文件 X，将文件 X 的 A 列中的所有内容复制到主文件的 B 列，然后在主文件的 B 列中为 B 列中有数据的每一行插入一个日期

我被困在第 5 步，无法找到一种方法来找到从第 4 步中粘贴了数据的所有单元格，并将所有单元格的值直接设置到它们的左侧。

Option Explicit

Sub ImportGroups()
Dim fPATH As String, fNAME As String
Dim LR As Long, NR As Long
Dim wbGRP As Workbook, wsDEST As Worksheet
Dim dateChooser As Variant
Dim cell As Range


Set wsDEST = ActiveWorkbook.Sheets("Sheet1")


Application.DisplayAlerts = False

fPATH = "C:\<path>\"       'remember the final \ in this string

fNAME = Dir(fPATH & "*")        'get the first filename in fpath

Do While Len(fNAME) > 0
    Set wbGRP = Workbooks.Open(fPATH & fNAME)   'open the file
    LR = Range("A" & Rows.Count).End(xlUp).Row  'how many rows of info?

    If LR > 3 Then

        dateChooser = InputBox("Enter date based on this file name: " & fNAME)

        ActiveSheet.Range("A1:A" & LR).Copy
        wsDEST.Cells(Rows.Count, 2).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValue

        ' This is where I need to set the value of all cells adjacent to the pasted cells

    End If

    wbGRP.Close False   'close data workbook
        fNAME = Dir         'get the next filename
Loop
Application.DisplayAlerts = True

End Sub

Answer 1

也许是这样的。

1. 您需要计算每个工作簿（目标和导入）的最后一行，而您目前只为看起来像的一本书这样做。对于您的目标书，第一个可用的空白行 (LR) 将在您每次粘贴到新范围时更改，因此需要在打开另一本书之前在循环内重新计算。在您的导入书籍上，每个文件可能会有不同的行，因此这需要它自己的最后一行计算 (LR2)。
2. 我在ws 中对您的工作表进行了限定，这指的是您目标书上的Sheet1。然后，我们将使用wbGRP.Sheets(1)，它将引用您打开的每本导入书的第一张纸。这可能需要更正（等待您在 cmets 中的回复）
3. 对于第 5 步，您将需要遍历 ws 上新粘贴的数据。这些行存在的位置可以从您的变量LR 和LR2 中推断出来。然后只需检查Column A 在循环内是否为空白，并在所需列上输出dateChooser。我在这里将dateChooser 粘贴到Column B 中（还在等待您在 cmets 中的回复）
4. 感谢Option Explicit。我确实在这里重新组织了一些事情（在屏幕更新之外声明静态，变量等分组等。

这未经测试。当您在 cmets 中遇到问题时，我们很乐意进行编辑

---

Option Explicit

Sub ImportGroups()

Dim ws As Worksheet: Set ws = ThisWorkbook.Sheets("Sheet1")
Dim fPATH As String, fNAME As String
Dim LR As Long, LR2 As Long, i As Long
Dim wbGRP As Workbook, dateChooser As Variant

fPATH = "C:\<path>\"
fNAME = Dir(fPATH & "*")

Application.DisplayAlerts = False
    Do While Len(fNAME) > 0
        Set wbGRP = Workbooks.Open(fPATH & fNAME)   'open the file
        LR = ws.Range("A" & Rows.Count).End(xlUp).Offset(1).Row  'how many rows of info?

        If LR > 3 Then
            dateChooser = InputBox("Enter date based on this file name: " & fNAME)
            LR2 = wbGRP.Sheets(1).Range("A" & wbGRP.Sheets(1).Rows.Count).End(xlUp).Row
            wbGRP.Sheets(1).Range("A1:A" & LR2).Copy
            ws.Range("B" & LR).End(xlUp).PasteSpecial xlPasteValues

            For i = LR To (LR + LR2 - 1)
                If ws.Range("A" & i) = "" Then ws.Range("B" & i) = dateChooser
            Next i
        End If

        wbGRP.Close False
        fNAME = Dir
    Loop
Application.DisplayAlerts = True

End Sub