根据条件将行从一个工作簿复制到另一个工作簿

Question

这是我每天必须做的事情，随着时间的推移，它开始在 *** 中疼痛。

我需要编写一个代码，该代码基于 A 列中的值，将同一行中 B:I 列中的值复制到另一个工作簿。数据源将始终相同。我在 A 列中最多有 30 个工作簿/30 个唯一值。

如果单元格 A1 中的值 =“苹果”。我需要将范围 B1:I1 复制到名为 apples 的工作簿。 如果单元格 A2 中的值 = "Oranges"，我需要将范围 B2:I2 复制到名为 oranges 的工作簿中...

等等等等。

目标工作簿位于另一个文件夹中。我需要在目标工作簿的 A 列中找到最后一行，然后立即插入我的源区域。我基本上需要用我复制的数据创建新行。

任何帮助将不胜感激。

下面是我尝试自己编写的代码，但不幸的是没有运气。循环仅为一个工作簿创建。

编辑。

A 列中的值与它们应复制到的工作簿的名称不对应。格式为 .xlsx 的工作簿

A 列：I 是源工作表中唯一的列。

我将从源中的 B:I 复制到目标中的 A:H。所有目标工作簿的格式都相同。在复制到目标工作簿时，我需要插入额外的行，然后将数据复制进去。

我需要始终复制到目标工作簿的第一个选项卡中。全部称为“所有行业”

将有一个或多个记录（行）被复制到每个目标工作簿。

非常感谢，

Sub copying()
 
    Dim wsIn As Worksheet, ws4 As Workbook, ws5 As Workbook, ws6 As Workbook, ws7 As Workbook, ws8 As Workbook, ws9 As Workbook, ws10 As Workbook, ws11 As Workbook, ws12 As Workbook, ws13 As Workbook
    Dim ws14 As Workbook, ws15 As Workbook, ws16 As Workbook, ws17 As Workbook, ws18 As Workbook, ws19 As Workbook, ws20 As Workbook, ws21 As Workbook, ws22 As Workbook, ws23 As Workbook, ws24 As Workbook, ws25 As Workbook, ws26 As Workbook, ws27 As Workbook
    Dim wsE1 As Workbook, wsE2 As Workbook, wsE3 As Workbook, wsE4 As Workbook, wsE5 As Workbook, wsE6 As Workbook
    
    Dim wkExport As Workbook
    
    Dim fn4 As String, fn5 As String, fn6 As String, fn7 As String, fn8 As String, fn9 As String, fn10 As String, fn11 As String, fn12 As String, fn13 As String, fn14 As String, fn15 As String, fn16 As String, fn17 As String, fn18 As String, fn19 As String, fn20 As String
    Dim fn21 As String, fn22 As String, fn23 As String, fn24 As String, fn25 As String, fn26 As String, fn27 As String
    Dim fnE1 As String, fnE2 As String, fnE3 As String, fnE4 As String, fnE5 As String, fnE6 As String
    
    Set wsIn = ThisWorkbook.Worksheets("Ready_data")
    fn5 = ThisWorkbook.Path & Application.PathSeparator & "workbook5.xlsx"
    
    
    wsIn.Range("A2:I" & ws5.Rows.Count).Clear
    
    Dim lrowIn As Long
    lrowIn = wsIn.Range("A1").CurrentRegion.Rows.Count
    Dim lrowOut As Long
    Dim i As Long
    
    For i = 2 To lrowIn
        If wsIn.Range("A" & i).Value = "workbook5" Then
        Set wkExport = Workbooks.Open(fn5)
        lrowOut = ws5.Range("A1").CurrentRegion.Rows.Count + 1
        wsIn.Range("B" & i & ":I" & i).Copy ws5.Cells(lrowOut, 1)
    
    End If
    Next iM
        
End Sub

我已经尝试了很多 youtube 视频并浏览了 stackoverflow 中的所有建议，但没有什么与我需要的完全相同。

Answer 1

子复制()

Dim wsIn As Worksheet, ws4 As Workbook, ws5 As Workbook, ws6 As Workbook, ws7 As Workbook, ws8 As Workbook, ws9 As Workbook, ws10 As Workbook, ws11 As Workbook, ws12 As Workbook, ws13 As Workbook
Dim ws14 As Workbook, ws15 As Workbook, ws16 As Workbook, ws17 As Workbook, ws18 As Workbook, ws19 As Workbook, ws20 As Workbook, ws21 As Workbook, ws22 As Workbook, ws23 As Workbook, ws24 As Workbook, ws25 As Workbook, ws26 As Workbook, ws27 As Workbook
Dim wsE1 As Workbook, wsE2 As Workbook, wsE3 As Workbook, wsE4 As Workbook, wsE5 As Workbook, wsE6 As Workbook

Dim wkExport As Workbook

Dim fn4 As String, fn5 As String, fn6 As String, fn7 As String, fn8 As String, fn9 As String, fn10 As String, fn11 As String, fn12 As String, fn13 As String, fn14 As String, fn15 As String, fn16 As String, fn17 As String, fn18 As String, fn19 As String, fn20 As String
Dim fn21 As String, fn22 As String, fn23 As String, fn24 As String, fn25 As String, fn26 As String, fn27 As String
Dim fnE1 As String, fnE2 As String, fnE3 As String, fnE4 As String, fnE5 As String, fnE6 As String

Set wsIn = ThisWorkbook.Worksheets("Ready_data")
fn5 = ThisWorkbook.Path & Application.PathSeparator & "workbook5.xlsx"


wsIn.Range("A2:I" & ws5.Rows.Count).Clear

Dim lrowIn As Long
lrowIn = wsIn.Range("A1").CurrentRegion.Rows.Count
Dim lrowOut As Long
Dim i As Long

For i = 2 To lrowIn
    If wsIn.Range("A" & i).Value = "workbook5" Then
    Set wkExport = Workbooks.Open(fn5)
    lrowOut = ws5.Range("A1").CurrentRegion.Rows.Count + 1
    wsIn.Range("B" & i & ":I" & i).Copy ws5.Cells(lrowOut, 1)

End If
Next iM
    

结束子

Answer 2

查找数据并将行复制到工作簿

Option Explicit

Sub UpdateTrades()
    
    ' Define constants.
    Const PROC_TITLE As String = "Update Trades"
    Const SRC_NAME As String = "Read_Data" ' get rid of the ugly '_'
    Const DST_PATH As String = "C:TEST"
    Const DST_NAME As String = "All Trades"
    Const DST_EXTENSION_PATTERN As String = ".xlsx"
    
    ' Determine the destination path.
    
    Dim pSep As String: pSep = Application.PathSeparator
    Dim dFolderPath As String: dFolderPath = DST_PATH
    If Right(dFolderPath, 1) <> pSep Then dFolderPath = dFolderPath & pSep
    
    Dim dFolderName As String: dFolderName = Dir(dFolderPath, vbDirectory)
    If Len(dFolderName) = 0 Then
        MsgBox "The destination path '" & dFolderPath & "' doesn't exist.", _
            vbCritical, PROC_TITLE
        Exit Sub
    End If
    
    ' Write the source data to arrays.
    
    Dim swb As Workbook: Set swb = ThisWorkbook ' workbook containing this code
    Dim sws As Worksheet: Set sws = swb.Worksheets(SRC_NAME)
    
    Dim srg As Range, srCount As Long, cCount As Long
    
    With sws.Range("A1").CurrentRegion
        srCount = .Rows.Count - 1 ' remove headers
        cCount = .Columns.Count - 1 ' remove lookup column
        Set srg = .Resize(srCount).Offset(1)
    End With
    
    Dim lData() As Variant: lData = srg.Columns(1).Value ' 1st column
    Dim sData() As Variant: sData = srg.Resize(, cCount).Offset(, 1).Value
    
    ' Write the unique data from the lookup array to a dictionary.
    ' The 'keys' will hold the values while the 'items' will hold
    ' a collection of the row numbers.
    
    Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
    dict.CompareMode = vbTextCompare
    
    Dim sr As Long, sString As String
    
    For sr = 1 To srCount
        sString = CStr(lData(sr, 1))
        If Len(sString) > 0 Then
            If Not dict.Exists(sString) Then
                Set dict(sString) = New Collection
            End If
            dict(sString).Add sr
        End If
    Next sr
    
    Erase lData
    
    Application.ScreenUpdating = False
    
    ' Write the values from the source array and the dictionary
    ' to the destination array, write to, save and close the destination files.
    
    Dim dwb As Workbook, dws As Worksheet, drg As Range
    Dim dData As Variant, sKey As Variant, sItem As Variant
    Dim c As Long, dr As Long, drCount As Long
    Dim dPattern As String, dName As String, dPath As String
    
    ' Loop over the keys of the dictionary.
    For Each sKey In dict.Keys
        ' Determine the existence of a destination file.
        dPattern = dFolderPath & "*" & sKey & "*" & DST_EXTENSION_PATTERN
        dName = Dir(dPattern)
        If Len(dName) > 0 Then ' the destination file exists
            ' Define the destination array.
            drCount = dict(sKey).Count
            ReDim dData(1 To drCount, 1 To cCount)
            dr = 0 ' reset destination row counter
            ' Loop over the row numbers in the current collection.
            For Each sItem In dict(sKey)
                dr = dr + 1
                ' Write the current row from the source to the destination.
                For c = 1 To cCount
                    dData(dr, c) = sData(sItem, c)
                Next c
            Next sItem
            ' Open, write from the destination array, save and close.
            dPath = dFolderPath & dName
            Set dwb = Workbooks.Open(dPath)
            Set dws = dwb.Worksheets(DST_NAME)
            With dws.Range("A1").CurrentRegion
                Set drg = .Cells(1).Offset(.Rows.Count).Resize(drCount, cCount)
                drg.Value = dData
            End With
            dwb.Close SaveChanges:=True
        Else ' the destination file doesn't exist; print an alert
            Debug.Print "The pattern '" & dPattern & "' didn't return a file."
        End If
    Next sKey
    
    Application.ScreenUpdating = True

    ' Inform.        
    MsgBox "Trades updated.", vbInformation, PROC_TITLE
        
End Sub