Question

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

我的问题是每次粘贴时我无法通过该功能向下移动行。我想让它逐步粘贴新行上的值，即。 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

只需替换DoStuff和Edit潜艇希望这有帮助。

Answer 2

未测试：

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循环中创建一个调用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

使用增量行将多个文件中的数据复制到一个工作表中。

4 个答案: