vba - 如何使用 VBA 根据行数增加单元格

Question

假设我有 2 个文件:

FILE1.xls
FILE2.xls

FILE1.xls 包含:

AAA
BBB

FILE2.xls 包含:

XXX
YYY
ZZZ

我目前有这个代码:

  Sub LoopAllExcelFilesInFolder()

'PURPOSE: To loop through all Excel files in a user specified folder and perform a set task on them
'SOURCE: www.TheSpreadsheetGuru.com

Dim wb As Workbook
Dim myPath As String
Dim myFile As String
Dim myExtension As String
Dim FldrPicker As FileDialog
Dim FileName As String
Dim FileName1 As String

Dim bookList As Workbook
Dim mergeObj As Object, dirObj As Object, filesObj As Object, everyObj As Object

'Optimize Macro Speed
  Application.ScreenUpdating = False
  Application.EnableEvents = False
  Application.Calculation = xlCalculationManual

'Retrieve Target Folder Path From User
  Set FldrPicker = Application.FileDialog(msoFileDialogFolderPicker)

    With FldrPicker
      .Title = "Select A Target Folder"
      .AllowMultiSelect = False
        If .Show <> -1 Then GoTo NextCode
        myPath = .SelectedItems(1) & "\"
    End With

'In Case of Cancel
NextCode:
  myPath = myPath
  If myPath = "" Then GoTo ResetSettings

'Target File Extension (must include wildcard "*")
  myExtension = "*.xls"

'Target Path with Ending Extention
  myFile = Dir(myPath & myExtension)

'Loop through each Excel file in folder
  Do While myFile <> ""
    'Set variable equal to opened workbook
      Set wb = Workbooks.Open(FileName:=myPath & myFile)

    'Change First Worksheet's Background Fill Blue
      FileName = wb.Name
      FileName1 = Replace(FileName, ".xls", "")
      Range("B1:B2").Value = FileName1
    'Save and Close Workbook
      wb.Close SaveChanges:=True

    'Get next file name
      myFile = Dir
  Loop

'Message Box when tasks are completed
  MsgBox "Task Complete!"


  Application.ScreenUpdating = False
Set mergeObj = CreateObject("Scripting.FileSystemObject")

'change folder path of excel files here
Set dirObj = mergeObj.Getfolder("C:\Users\guintop\Desktop\paul\MERGE")
Set filesObj = dirObj.Files
For Each everyObj In filesObj
Set bookList = Workbooks.Open(everyObj)

'change "A2" with cell reference of start point for every files here
'for example "B3:IV" to merge all files start from columns B and rows 3
'If you're files using more than IV column, change it to the latest column
'Also change "A" column on "A65536" to the same column as start point
Range("A2:IV" & Range("A65536").End(xlUp).Row).Copy
ThisWorkbook.Worksheets(1).Activate

'Do not change the following column. It's not the same column as above
Range("A65536").End(xlUp).Offset(1, 0).PasteSpecial
Application.CutCopyMode = False
bookList.Close
Next



ResetSettings:
  'Reset Macro Optimization Settings
    Application.EnableEvents = True
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True

End Sub

如果我运行此代码，它将:

获取所选目录中存在的文件的文件名，

在每个文件的指定单元格中插入文件名(不带扩展名)

代码的最后一部分将所有文件合并到一个 excel 文件中。

并将有这样的输出作为最终输出文件

AAA FILE1   
BBB FILE1
XXX FILE2
YYY FILE2
ZZZ        -> BLANK

正如您所注意到的，ZZZ 的最后一部分将是空白的，因为我在特定单元格上分配了文件名。
如何调整此代码以自动填写单元格 B1-B3？如果我在单元格 A 中有 5 行数据，还是 B1-B5？

Answer 1

查找具有值的最后一行。

Dim ws As Excel.Worksheet
Dim lastRow As Long

Set ws = ActiveWorkbook.Sheets("Sheet1")

lastRow = ws.Cells(ws.Rows.count, "A").End(xlUp).Row

然后使用该值而不是对行进行硬编码。

Range("B1:B" & lastRow).Value = FileName1