从多个文件中提取数据并在Excel中相应地命名数据
我有一个运行的macros，从一个文件夹中的许多文件中提取数据，并将该文件中的内容粘贴到一个主文件中。 所有的数据都被正确地粘贴在主文件中，但是我需要把数据从粘贴到主文件中的文件的名称也一样。
我的macros是：
Dim MyFile As String, Sep As String Application.ScreenUpdating = False Application.DisplayAlerts = False Application.EnableEvents = False Dim wks1 As Worksheet, wks2 As Worksheet, objwb As Workbook, objwb0 As Workbook Dim last_rowcurent As Long Dim last_row As Long Sheets("Warnings").Select last_rowcurent = Range("B1").End(xlDown).Row + 1 Set objwb0 = ActiveWorkbook Set wks1 = objwb0.Worksheets("Warnings") ' Sets up the variable "MyFile" to be each file in the directory ' This example looks for all the files that have an .xls extension. ' This can be changed to whatever extension is needed. Also, this ' macro searches the current directory. This can be changed to any ' directory. '' Test for Windows or Macintosh platform. Make the directory request. Sep = Application.PathSeparator 'If Sep = "\" Then ' Windows platform search syntax. MyFile = Dir("P:\Frame\Frame_Piercing\Metrics_Development\Inmagusa\Warnings" & Sep & "*.xls") 'Else ' Macintosh platform search syntax. 'MyFile = Dir("", MacID("XLS5")) 'End If ' Starts the loop, which will continue until there are no more files ' found. Do While MyFile <> "" Application.ScreenUpdating = False Application.CutCopyMode = False ' Displays a message box with the name of the file. This can be ' changed to any procedure that would be needed to run on every ' file in the directory such as opening each file. last_rowcurent = wks1.Range("B2").End(xlDown).Row + 1 Set objwb = Workbooks.Open("P:\Frame\Frame_Piercing\Metrics_Development\Inmagusa\Warnings" & Sep & MyFile) Set wks2 = objwb.Worksheets("navistar-warnings") Sheets("navistar-warnings").Select last_row = wks2.Range("A2").End(xlDown).Row If Not IsEmpty(Range("A2")) Then 'MsgBox last_row wks2.Range("A2:h" & last_row).Select Selection.Copy Workbooks("Inmagusa_Merge_Files.xlsm").Activate Worksheets("Warnings").Range("A1").Select 'Sheets("Errors").Select last_rowcurent = ActiveSheet.Range("B1").End(xlDown).Row + 1 ActiveSheet.Range("A" & last_rowcurent).Select 'ActiveWorkbook.Worksheets("Release").Range("A" & lastrowcurent).Select Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False 'Selection.PasteSpecial Paste:=x1PasteFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False 'Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, _ SkipBlanks:=True, Transpose:=False 'wks1.Range("A" & last_rowcurent).PasteSpecial(Paste:=x1PasteValues, Paste:=x1PasteFormats, Operation:= _ x1None, SkipBlanks:=False, Transpose:=False) 'wks1.Range("A" & last_rowcurent).Select 'Selection.PasteSpecial Paste:=xlPasteValues, x1PasteFormats, Operation:= _ 'xlNone, SkipBlanks:=False, Transpose:=False 'wks2.Range("A4:w" & last_row).Copy 'wks1.Range("A" & last_rowcurent).Select 'Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _ 'SkipBlanks:=False, Transpose:=False 'Workbooks("Frame_WorkPlanning_Master.xlsm").Activate 'last_rowcurent = ActiveWorkbook.Worksheets("Release").Range("A3").Row 'ActiveWorkbook.Worksheets("Release").Range("a3").Paste 'With wks1.Range("A" & last_rowcurent) '.PasteSpecial Paste:=xlPasteColumnWidths '.PasteSpecial Paste:=xlPasteFormats '.PasteSpecial Paste:=xlValue 'or other parameters... 'End With End If objwb.Close False 'MsgBox "P:\Frame\Work_Planning\Engineer_Plans" & Sep & MyFile MyFile = Dir() Loop 'ActiveWorkbook.Worksheets("Release").Protect DrawingObjects:=False, Contents:=True, Scenarios:= _ False, AllowSorting:=True, AllowFiltering:=True, AllowFormattingCells:=True, AllowUsingPivotTables:= _ 我需要粘贴在“I”列中的文件名，但是行数随每个单独文件中的数据而变化。
任何帮助将不胜感激！
你有很多代码被注释掉了，这使得它有点难以遵循。 我忽略了所有的评论代码，并重写了有问题的部分，以消除Active和Select 。 看到这个post了解更多关于为什么这是一个好主意。
现在，文件名将被打印在正在粘贴的第一行新数据的第一列上
Dim wbSource As Workbook Set wbSource = Workbooks("Inmagusa_Merge_Files.xlsm") If Not IsEmpty(Range("A2")) Then wks2.Range("A2:h" & last_row).Copy last_rowcurent = wbSource.Worksheets("Warnings").Range("B1").End(xlDown).Row + 1 ' Put file name in Column I on the first row of new data wbSource.Worksheets("Warnings").Range("I" & last_rowcurent).Value = objwb.Name wbSource.Worksheets("Warnings").Range("A" & last_rowcurent).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False End If
编辑
要将每一行新数据的名称粘贴到列I中，您可以像这样循环：
Dim wbSource As Workbook Set wbSource = Workbooks("Inmagusa_Merge_Files.xlsm") If Not IsEmpty(Range("A2")) Then Dim copyRange As Range Set copyRange = wks2.Range("A2:h" & last_row) copyRange.Copy last_rowcurent = wbSource.Worksheets("Warnings").Range("B1").End(xlDown).Row + 1 ' Put file name in Column I on the first row of new data 'wbSource.Worksheets("Warnings").Range("I" & last_rowcurent).Value = objwb.Name ' Put file name in Column I for every row being pasted For j = 1 + last_rowcurent To copyRange.Rows.Count + last_rowcurent wbSource.Worksheets("Warnings").Range("I" & j).Value = objwb.Name Next j wbSource.Worksheets("Warnings").Range("A" & last_rowcurent).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False End If
请注意，我将单行代码注释掉，并添加到For循环中以打印每个单元格的名称。