DougStroud
Well-known Member
- Joined
- Aug 16, 2005
- Messages
- 2,968
I have to add constants to a worksheet with the use of VBA.
Column "X" will need the term "Yes", beginning at the last non-blank cell in column "B" and Column "AA" will need the term "EOREOR" to "AA4" using column "B" as the reference column/row.
Here is my code:
Thanks,
Doug
Column "X" will need the term "Yes", beginning at the last non-blank cell in column "B" and Column "AA" will need the term "EOREOR" to "AA4" using column "B" as the reference column/row.
Here is my code:
Code:
Sub CopyColumns()
Dim y, z, a, b, w, x
Dim lr As Long, numColumns As Long, i As Long, ii As Long, iii As Long
Dim ws1 As Worksheet, ws2 As Worksheet, ws3 As Worksheet
Dim rng1 As Range, rng2 As Range
Set ws1 = Workbooks("MasterImportSheetWebStore.xls").Sheets("PCCombined_FF")
Set ws2 = Workbooks("MasterImportSheetWebStore.xls").Sheets("PCCombined_VB")
Set ws3 = Workbooks("Complete_Upload_File.xls").Sheets("EC Products")
a = Array(1, 2, 4, 5, 8, 10, 22, 30, 31, 25, 27, 28, 29) ' Change to columns to copy from (separate with ,) Sum must match numColumns
b = Array(1, 2, 3, 19, 8, 4, 11, 16, 15, 20, 21, 22, 23) ' Change to columns to paste to (separate with ,) Sum must match numColumns
numColumns = UBound(a) + 1
If UBound(a) <> UBound(b) Then
MsgBox "The sum of elements in array a and b must match."
Exit Sub
End If
Application.ScreenUpdating = False
ReDim y(1 To 1, 1 To numColumns): ReDim z(1 To 1, 1 To numColumns)
For i = 1 To numColumns
y(1, i) = ws1.Range(ws1.Cells(4, a(i - 1)), _
ws1.Cells(ws1.Cells(Rows.Count, 1).End(xlUp).Row, a(i - 1)))
z(1, i) = ws2.Range(ws2.Cells(4, a(i - 1)), _
ws2.Cells(ws2.Cells(Rows.Count, 1).End(xlUp).Row, a(i - 1)))
Next
iii = UBound(y(1, 2))
For i = 1 To numColumns
ws3.Range(ws3.Cells(4, b(i - 1)), ws3.Cells(iii + 3, b(i - 1))) = y(1, i)
ws3.Range(ws3.Cells(4 + iii, b(i - 1)), ws3.Cells(UBound(z(1, 2)) + 3 + iii, b(i - 1))) = z(1, i)
Next
lr = Application.Max(ws1.Cells(Rows.Count, "Q").End(xlUp).Row, _
ws1.Cells(Rows.Count, "T").End(xlUp).Row)
w = ws1.Range(ws1.Cells(4, 17), ws1.Cells(lr, 17))
x = ws1.Range(ws1.Cells(4, 20), ws1.Cells(lr, 20))
For i = 1 To UBound(w)
w(i, 1) = w(i, 1) & x(i, 1)
Next i: iii = lr + 1
ws3.Range("j4:j" & lr) = w: Erase w: Erase x
lr = Application.Max(ws2.Cells(Rows.Count, "Q").End(xlUp).Row, _
ws2.Cells(Rows.Count, "T").End(xlUp).Row)
w = ws2.Range(ws2.Cells(4, 17), ws2.Cells(lr, 17))
x = ws2.Range(ws2.Cells(4, 20), ws2.Cells(lr, 20))
For i = 1 To UBound(w)
w(i, 1) = w(i, 1) & x(i, 1)
Next i
ws3.Range("j" & iii & ":j" & iii + (lr - 4)) = w
Application.ScreenUpdating = True
End Sub
Thanks,
Doug