This is something that I have to do daily and over time it started to be pain in the ***.
I need to write a code which based on a value in Column A, copies values in columns B:I in the same row to another workbook. Source of the data will always be the same. I have the maximum of 30 workbooks/30 unique values in column A.
If a value in cell A1 = "Apples". I need to copy range B1:I1 to workbook called apples. If a value in cell A2 = "Oranges", I need to copy range B2:I2 to workbook called oranges...
and so on and so forth.
Destination Workbooks are located in another folder. I need to find a last row in column A in destination workbook and insert my source range right after. I basically need to create new rows with the data I copy in.
Any help will be greatly appreciated.
Below is the code I tried to write myself, but unfortunately no luck. loop is only created for one workbook.
EDIT.
Values in the column A do not correspond with the names of the workbooks they should be copied in. Workbooks in Format .xlsx
Columns A:I are the only columns in the source sheet.
I will be copying from B:I in the source to A:H in the destination. All destination workbooks are formatted in the same way. While copying into destination workbooks, I need to insert extra rows and then copy the data in.
I need to always copy into the first tab in destination workbook. All called "All trades"
There will be one or more than one record (row) to be copied to each destination workbook.
Many thanks,
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
I tried a lot of youtube videos already and went through all the suggestions in stackoverflow but nothing is quite the same to what I need.
CodePudding user response：
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
CodePudding user response：
Lookup Data and Copy Rows to Workbooks
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