将来自多个文件的数据复制到具有增量行的一个表中。

我使用下面的代码来打开多个文件之一，从工作表中复制一行，然后将其粘贴回第一个工作表，然后closures打开的文件。

我的问题是，我不能通过function，每次贴下去的行。 我希望它增量粘贴新行上的值，即。 B3 ，然后是B4 ，然后是B5等

 Sub Auto_open_change() Dim WrkBook As Workbook Dim StrFileName As String Dim FileLocnStr As String Dim LAARNmeWrkbk As String PERNmeWrkbk = ThisWorkbook.Name FileLocnStr = "T:\Projects\data" 'ThisWorkbook.Path Dim StrFile As String StrFile = Dir(FileLocnStr & "\*.xls") Do While Len(StrFile) > 0 DoStuff (FileLocnStr & "\" & StrFile) StrFile = Dir Loop End Sub Private Sub DoStuff(StrFileName) Workbooks.Open (StrFileName) Call Edit Workbooks.Open (StrFileName) ActiveWorkbook.Close End Sub Sub Edit() Dim Wb1 As Workbook Dim ws1 As Worksheet Dim loopcal As Long With Application .ScreenUpdating = False .EnableEvents = False lngCalc = .Calculation End With Set Wb1 = ActiveWorkbook Sheets("1_3 Octave1 CH1").Select Range("A3:AH3").Select Selection.Copy Windows("template.xlsm").Activate Sheets("Data Extract").Select Range("B3").Select Selection.PasteSpecial Paste:=xlPasteAllUsingSourceTheme, Operation:=xlNone, SkipBlanks:=False, Transpose:=False Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False End Sub 

Answer 1

你可以试试这个：

 Sub GetData(Fname as String) Dim wb1, wb2 as Workbook Dim ws1, ws2 as Worksheet Dim lrow as Long Set wb1 = Thisworkbook Set ws1 = wb1.Sheets("DataExtract") Set wb2 = Worbooks.Open(Fname) Set ws2 = wb2.Sheets("1_3 Octave1 CH1") With ws1 lrow = .Range("B" & Rows.Count).End(xlUp).Row ws2.Range("A3:AH3").Copy .Range("B" & lrow).Offset(1,0).PasteSpecial xlPasteValues Application.CutCopyMode = False End With wb2.Close False End Sub 

只需要replaceDoStuff和Edit subs。
希望这可以帮助。

Answer 2

未经testing：

 Sub Auto_open_change() Dim StrFileName As String Dim FileLocnStr As String Dim fNum As Long Dim StrFile As String FileLocnStr = "T:\Projects\data" 'ThisWorkbook.Path With Application .ScreenUpdating = False .EnableEvents = False End With fNum = 1 StrFile = Dir(FileLocnStr & "\*.xls") Do While Len(StrFile) > 0 CopyData FileLocnStr & "\" & StrFile, fNum StrFile = Dir fNum = fNum + 1 Loop With Application .ScreenUpdating = True .EnableEvents = True End With End Sub Sub CopyData(StrFileName As String, fNum As Long) Dim Wb1 As Workbook, rngCopy As Range Dim rngDest As Range Set Wb1 = Workbooks.Open(StrFileName) Set rngCopy = Wb1.Sheets("1_3 Octave1 CH1").Range("A3:AH3") Set rngDest = ThisWorkbook.Sheets("Data Extract") _ .Range("B2").Offset(fNum, 0) rngCopy.Copy rngDest With rngDest.Resize(rngCopy.Rows.Count, rngCopy.Columns.Count) .Value = .Value End With Wb1.Close False End Sub 

Answer 3

那么，使用你正在使用的代码，你可以在Do While循环中创build一个variables来调用DoStuff并把它传递给Edit子，然后构造一个范围。

所以在Do While Loop中

 rowcounter = 3 Do While Len(StrFile) > 0 DoStuff (FileLocnStr & "\" & StrFile, rowcounter) StrFile = Dir rowcounter = rowcounter + 1 Loop 

然后修改DoStuff

 Private Sub DoStuff(StrFileName As String, rowcounter As Integer) Workbooks.Open (StrFileName) Call Edit(rowcounter) Workbooks.Open (StrFileName) ActiveWorkbook.Close End Sub 

然后修改编辑

 Sub Edit(rowcounter As Integer) . . . . Windows("template.xlsm").Activate Sheets("Data Extract").Select Range("B" & rowcounter).Select . . End Sub 

Answer 4

“伙计们，这是最后的编辑。 完美的作品，谢谢你们的帮助和支持。

 Option Explicit Sub Auto_open_change() Dim WrkBook As Workbook Dim StrFileName As String Dim FileLocnStr As String Dim LAARNmeWrkbk As String Dim rowcounter As Integer FileLocnStr = "T:\Projects\data" 'ThisWorkbook.Path Dim StrFile As String StrFile = Dir(FileLocnStr & "\*.xls") rowcounter = 3 Do While Len(StrFile) > 0 Call DoStuff(FileLocnStr & "\" & StrFile, rowcounter) StrFile = Dir rowcounter = rowcounter + 1 Loop End Sub Private Sub DoStuff(StrFileName As String, rowcounter As Integer) Workbooks.Open (StrFileName) Call Edit(rowcounter) Workbooks.Open (StrFileName) ActiveWorkbook.Close End Sub Sub Edit(rowcounter As Integer) Dim Wb1 As Workbook Dim ws1 As Worksheet Dim loopcal As Long With Application .ScreenUpdating = True .EnableEvents = True lngCalc = .Calculation End With Set Wb1 = ActiveWorkbook Sheets("1_3 Octave1 CH1").Select Range("A3:AH3").Select Selection.Copy Windows("template.xlsm").Activate Sheets("Data Extract").Select Range("B" & rowcounter).Select 'index the variable to ensure the cell reference changes each time. Selection.PasteSpecial Paste:=xlPasteAllUsingSourceTheme, Operation:=xlNone, SkipBlanks:=False, Transpose:=False Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False End Sub