wo_ofberry
New Member
- Joined
- Feb 5, 2023
- Messages
- 6
- Office Version
- 365
- Platform
- Windows
I am copying data from Sourcebook1 to targetbook1.
Sourcebook1:
targetbook1
Below is my attempt code, it has run time error after 'Copy the data to the target workbook. Notice that the positions of the headers are very different, as well as the headers of targetbook1 are merged cells. Please assist in resolving the error.
Sourcebook1:
Sourcebook1.xlsx | |||||||||||||||
---|---|---|---|---|---|---|---|---|---|---|---|---|---|---|---|
A | B | C | D | E | F | G | H | I | J | K | L | M | |||
1 | |||||||||||||||
2 | |||||||||||||||
3 | |||||||||||||||
4 | |||||||||||||||
5 | |||||||||||||||
6 | |||||||||||||||
7 | |||||||||||||||
8 | |||||||||||||||
9 | |||||||||||||||
10 | Sourcebook1 | ||||||||||||||
11 | |||||||||||||||
12 | |||||||||||||||
13 | |||||||||||||||
14 | |||||||||||||||
15 | |||||||||||||||
16 | |||||||||||||||
17 | |||||||||||||||
18 | |||||||||||||||
19 | 2 | 3 | 4 | 5 | 6 | 7 | 8 | 9 | 10 | ||||||
20 | Date | Comments at Order Time | Comments on iPad | Name of signee | Location | Date | DO No. | Product Description | DO Qty | ||||||
21 | 123.00 | 132.00 | 141.00 | 150.00 | 159.00 | 168.00 | 177.00 | 186.00 | 195.00 | ||||||
22 | 124.00 | 133.00 | 142.00 | 151.00 | 160.00 | 169.00 | 178.00 | 187.00 | 196.00 | ||||||
23 | 125.00 | 134.00 | 143.00 | 152.00 | 161.00 | 170.00 | 179.00 | 188.00 | 197.00 | ||||||
24 | 126.00 | 135.00 | 144.00 | 153.00 | 162.00 | 171.00 | 180.00 | 189.00 | 198.00 | ||||||
25 | 127.00 | 136.00 | 145.00 | 154.00 | 163.00 | 172.00 | 181.00 | 190.00 | 199.00 | ||||||
26 | 128.00 | 137.00 | 146.00 | 155.00 | 164.00 | 173.00 | 182.00 | 191.00 | 200.00 | ||||||
27 | 129.00 | 138.00 | 147.00 | 156.00 | 165.00 | 174.00 | 183.00 | 192.00 | 201.00 | ||||||
28 | 130.00 | 139.00 | 148.00 | 157.00 | 166.00 | 175.00 | 184.00 | 193.00 | 202.00 | ||||||
29 | 131.00 | 140.00 | 149.00 | 158.00 | 167.00 | 176.00 | 185.00 | 194.00 | 203.00 | ||||||
30 | |||||||||||||||
31 | |||||||||||||||
32 | |||||||||||||||
Sheet1 |
targetbook1
Targetbook1.xlsx | ||||||||||||||||
---|---|---|---|---|---|---|---|---|---|---|---|---|---|---|---|---|
A | B | C | D | E | F | G | H | I | J | K | L | M | N | |||
1 | Targetbook1 | |||||||||||||||
2 | 4 | 5 | 6 | 7 | 8 | 9 | 10 | 11 | 12 | |||||||
3 | For Month (YYYY MM) | Comments at Order Time | Comments on iPad | Name of signee | For TAK or Subcon? [HSUENCHOW/Pintary/ BBR/ KKL..etc] | Date | DO No. | 1 | Qty | |||||||
4 | ||||||||||||||||
5 | ||||||||||||||||
6 | ||||||||||||||||
7 | ||||||||||||||||
8 | ||||||||||||||||
9 | ||||||||||||||||
10 | ||||||||||||||||
11 | ||||||||||||||||
12 | ||||||||||||||||
13 | ||||||||||||||||
14 | ||||||||||||||||
15 | ||||||||||||||||
16 | ||||||||||||||||
17 | ||||||||||||||||
18 | ||||||||||||||||
19 | ||||||||||||||||
20 | ||||||||||||||||
21 | ||||||||||||||||
22 | ||||||||||||||||
Sheet1 |
Below is my attempt code, it has run time error after 'Copy the data to the target workbook. Notice that the positions of the headers are very different, as well as the headers of targetbook1 are merged cells. Please assist in resolving the error.
VBA Code:
Option Explicit
Sub CopyData()
Dim sourceWorkbook As Workbook
Dim targetWorkbook As Workbook
Dim headerMap As Object
'Open the source workbook
Set sourceWorkbook = Workbooks.Open("C:\Users\User\Desktop\Trial 1\Sourcebook1.xlsx")
'Open the target workbook
Set targetWorkbook = Workbooks.Open("C:\Users\User\Desktop\Trial 1\Targetbook1.xlsx")
'Define the columns you want to copy
Dim column1 As String
Dim column2 As String
Dim column3 As String
Dim column4 As String
Dim column5 As String
Dim column6 As String
Dim column7 As String
Dim column8 As String
Dim column9 As String
'Set the column header names in the source workbook
column1 = "Date"
column2 = "Comments at Order Time"
column3 = "Comments on iPad"
column4 = "Name of signee"
column5 = "Location"
column6 = "Date"
column7 = "DO No."
column8 = "Product Description"
column9 = "DO Qty"
'Find the row number of the column header names in the source workbook
Dim column1Row As Integer
Dim column2Row As Integer
Dim column3Row As Integer
Dim column4Row As Integer
Dim column5Row As Integer
Dim column6Row As Integer
Dim column7Row As Integer
Dim column8Row As Integer
Dim column9Row As Integer
column1Row = 20
column2Row = 20
column3Row = 20
column4Row = 20
column5Row = 20
column6Row = 20
column7Row = 20
column8Row = 20
column9Row = 20
Dim i As Integer
For i = 1 To sourceWorkbook.Sheets(1).UsedRange.Rows.Count
If sourceWorkbook.Sheets(1).Cells(i, 1) = column1 Then
column1Row = i
Exit For
End If
Next i
For i = 1 To sourceWorkbook.Sheets(1).UsedRange.Rows.Count
If sourceWorkbook.Sheets(1).Cells(i, 1) = column2 Then
column2Row = i
Exit For
End If
Next i
For i = 1 To sourceWorkbook.Sheets(1).UsedRange.Rows.Count
If sourceWorkbook.Sheets(1).Cells(i, 1) = column3 Then
column3Row = i
Exit For
End If
Next i
For i = 1 To sourceWorkbook.Sheets(1).UsedRange.Rows.Count
If sourceWorkbook.Sheets(1).Cells(i, 1) = column4 Then
column4Row = i
Exit For
End If
Next i
For i = 1 To sourceWorkbook.Sheets(1).UsedRange.Rows.Count
If sourceWorkbook.Sheets(1).Cells(i, 1) = column5 Then
column5Row = i
Exit For
End If
Next i
For i = 1 To sourceWorkbook.Sheets(1).UsedRange.Rows.Count
If sourceWorkbook.Sheets(1).Cells(i, 1) = column6 Then
column6Row = i
Exit For
End If
Next i
For i = 1 To sourceWorkbook.Sheets(1).UsedRange.Rows.Count
If sourceWorkbook.Sheets(1).Cells(i, 1) = column7 Then
column7Row = i
Exit For
End If
Next i
For i = 1 To sourceWorkbook.Sheets(1).UsedRange.Rows.Count
If sourceWorkbook.Sheets(1).Cells(i, 1) = column8 Then
column8Row = i
Exit For
End If
Next i
For i = 1 To sourceWorkbook.Sheets(1).UsedRange.Rows.Count
If sourceWorkbook.Sheets(1).Cells(i, 1) = column9 Then
column9Row = i
Exit For
End If
Next i
'Define a dictionary to store the mapping of header names
Set headerMap = CreateObject("Scripting.Dictionary")
'Map the header names between the source and target workbooks
headerMap("Date") = "For Month (YYYY MM)"
headerMap("Comments at Order Time") = "Comments at Order Time"
headerMap("Comments on iPad") = "Comments on iPad"
headerMap("Name of signee") = "Name of signee"
headerMap("Location") = "For TAK or Subcon? [HSUENCHOW/Pintary/ BBR/ KKL..etc]"
headerMap("Date") = "Date"
headerMap("DO No.") = "DO No."
headerMap("Product Description") = "1"
headerMap("DO Qty") = "Qty"
'Find the row number of the target headers
Dim targetHeader1Row As Integer
Dim targetHeader2Row As Integer
Dim targetHeader3Row As Integer
Dim targetHeader4Row As Integer
Dim targetHeader5Row As Integer
Dim targetHeader6Row As Integer
Dim targetHeader7Row As Integer
Dim targetHeader8Row As Integer
Dim targetHeader9Row As Integer
targetHeader1Row = 3
targetHeader2Row = 3
targetHeader3Row = 3
targetHeader4Row = 3
targetHeader5Row = 3
targetHeader6Row = 3
targetHeader7Row = 3
targetHeader8Row = 3
targetHeader9Row = 3
For i = 1 To targetWorkbook.Sheets(1).UsedRange.Rows.Count
If targetWorkbook.Sheets(1).Cells(i, 1) = headerMap(column1) Then
targetHeader1Row = i
Exit For
End If
Next i
For i = 1 To targetWorkbook.Sheets(1).UsedRange.Rows.Count
If targetWorkbook.Sheets(1).Cells(i, 1) = headerMap(column2) Then
targetHeader2Row = i
Exit For
End If
Next i
For i = 1 To targetWorkbook.Sheets(1).UsedRange.Rows.Count
If targetWorkbook.Sheets(1).Cells(i, 1) = headerMap(column3) Then
targetHeader3Row = i
Exit For
End If
Next i
For i = 1 To targetWorkbook.Sheets(1).UsedRange.Rows.Count
If targetWorkbook.Sheets(1).Cells(i, 1) = headerMap(column4) Then
targetHeader4Row = i
Exit For
End If
Next i
For i = 1 To targetWorkbook.Sheets(1).UsedRange.Rows.Count
If targetWorkbook.Sheets(1).Cells(i, 1) = headerMap(column5) Then
targetHeader5Row = i
Exit For
End If
Next i
For i = 1 To targetWorkbook.Sheets(1).UsedRange.Rows.Count
If targetWorkbook.Sheets(1).Cells(i, 1) = headerMap(column6) Then
targetHeader6Row = i
Exit For
End If
Next i
For i = 1 To targetWorkbook.Sheets(1).UsedRange.Rows.Count
If targetWorkbook.Sheets(1).Cells(i, 1) = headerMap(column7) Then
targetHeader7Row = i
Exit For
End If
Next i
For i = 1 To targetWorkbook.Sheets(1).UsedRange.Rows.Count
If targetWorkbook.Sheets(1).Cells(i, 1) = headerMap(column8) Then
targetHeader8Row = i
Exit For
End If
Next i
For i = 1 To targetWorkbook.Sheets(1).UsedRange.Rows.Count
If targetWorkbook.Sheets(1).Cells(i, 1) = headerMap(column9) Then
targetHeader9Row = i
Exit For
End If
Next i
'Find the end row of the merged cells in the target workbook
Dim targetHeader1EndRow As Integer
Dim targetHeader2EndRow As Integer
Dim targetHeader3EndRow As Integer
Dim targetHeader4EndRow As Integer
Dim targetHeader5EndRow As Integer
Dim targetHeader6EndRow As Integer
Dim targetHeader7EndRow As Integer
Dim targetHeader8EndRow As Integer
Dim targetHeader9EndRow As Integer
targetHeader1EndRow = targetHeader1Row + 1
targetHeader2EndRow = targetHeader2Row + 1
targetHeader3EndRow = targetHeader3Row + 1
targetHeader4EndRow = targetHeader4Row + 1
targetHeader5EndRow = targetHeader5Row + 1
targetHeader6EndRow = targetHeader6Row + 1
targetHeader7EndRow = targetHeader7Row + 1
targetHeader8EndRow = targetHeader8Row + 1
targetHeader9EndRow = targetHeader9Row + 1
'Copy the data to the target workbook
targetWorkbook.Sheets(1).Range(targetWorkbook.Sheets(1).Cells(targetHeader1EndRow, 4),targetWorkbook.Sheets(1).Cells(targetHeader2EndRow,5),targetWorkbook.Sheets(1).Cells(targetHeader3EndRow,6),targetWorkbook.Sheets(1).Cells(targetHeader4EndRow, 7),targetWorkbook.Sheets(1).Cells(targetHeader5EndRow,8),targetWorkbook.Sheets(1).Cells(targetHeader6EndRow,9),targetWorkbook.Sheets(1).Cells(targetHeader7EndRow,10),targetWorkbook.Sheets(1).Cells(targetHeader8EndRow,11),targetWorkbook.Sheets(1).Cells(targetHeader9EndRow,12)).Value=sourceWorkbook.Sheets(1).Range(sourceWorkbook.Sheets(1).Cells(column1Row,2),sourceWorkbook.Sheets(1).Cells(column2Row,3),sourceWorkbook.Sheets(1).Cells(column3Row,4),sourceWorkbook.Sheets(1).Cells(column4Row,5),sourceWorkbook.Sheets(1).Cells(column5Row,6),sourceWorkbook.Sheets(1).Cells(column6Row,7),sourceWorkbook.Sheets(1).Cells(column7Row,8),sourceWorkbook.Sheets(1).Cells(column8Row,9),sourceWorkbook.Sheets(1).Cells(column9Row,10)).Value
'Save and close the workbooks
sourceWorkbook.Close savechanges:=False
End Sub