vba 将多个文件中的数据复制到一张带有增量行的工作表中。

Copy data from multiple files into one sheet with incremental rows.

提问by Adrian Gornall

I'm using the following code to open one of multiple files, copy a line from a worksheet, and then paste it back into the first worksheet, then close the opened file.

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

My problem is I can't get past the function to move down the rows each time it pastes. I want it to incrementally paste the values on the new row, ie. B3, then B4, then B5, etc.

我的问题是每次粘贴时我都无法通过向下移动行的功能。我希望它逐渐将值粘贴到新行上，即。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

回答by L42

You can try this:

你可以试试这个：

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

Just replace DoStuffand Editsubs.
hope this helps.

只需更换DoStuff和Edit潜艇。
希望这可以帮助。

回答by Tim Williams

Untested:

未经测试：

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

回答by Lance Roberts

Well, with the code you're using, you could just create a variable in the Do While Loop that calls DoStuff and pass it through to the Edit sub, then construct the range from that.

好吧，使用您正在使用的代码，您可以在调用 DoStuff 的 Do While 循环中创建一个变量并将其传递给 Edit sub，然后从中构造范围。

So in the Do While Loop

所以在 Do While 循环中

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

Then modify DoStuff

然后修改DoStuff

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

Then modify Edit

然后修改编辑

Sub Edit(rowcounter As Integer)
    .
    .

    .
    .

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

回答by Adrian Gornall

'Guys, here is the final edit. works perfectly, Thanks for the help and support guys.

'伙计们，这是最后的编辑。完美运行，感谢您的帮助和支持。

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