这是我每天必须做的事情，随着时间的推移，它开始在***疼痛。
我需要写一个基于a列值的代码，复制B列值:I在同一行到另一个工作簿。数据的来源总是相同的。我在a列中最多有30个工作簿/30个唯一值。
如果单元格A1中的值= "我需要复制范围B1:I1到名为苹果的工作簿。如果单元格A2中的值= "Oranges"，我需要将区域B2:I2复制到名为oranges…的工作簿
等等
目标工作簿位于另一个文件夹中。我需要在目标工作簿的a列中找到最后一行，并在之后插入我的源范围。我基本上需要用我复制的数据创建新行。
任何帮助都将非常感激。
下面是我试着自己写的代码，但不幸的是没有运气。循环仅为一个工作簿创建。
编辑。
列A中的值与应该复制它们的工作簿的名称不对应。.xlsx格式的工作簿
列A:I是源工作表中唯一的列。
我将从源文件中的B:I复制到目标文件中的A:H。所有目标工作簿都以相同的方式格式化。在复制到目标工作簿时，我需要插入额外的行，然后将数据复制到。
我需要总是复制到目标工作簿的第一个选项卡。都叫"All trades">
将有一个或多个记录(行)复制到每个目标工作簿。
许多谢谢,
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中的所有建议，但没有什么与我需要的完全相同。
查找数据并将行复制到工作簿
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
dict(sString).Add sr ' row to collection
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
Sub copy ()
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
结束子