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

如何使用VBA基于行数增加单元格

1 个答案: