Add Constant Value to Worksheet w/ VBA

[DougStroud]

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:

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

 

[dbmathis]

Is this what you wanted?

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

ws3.Range(Cells(4, 24), Cells(ws3.Cells(Rows.Count, 2).End(xlUp).Row, 24)) = "Yes"
ws3.Range(Cells(4, 26), Cells(ws3.Cells(Rows.Count, 2).End(xlUp).Row, 26)) = "Yes"
ws3.Range(Cells(4, 27), Cells(ws3.Cells(Rows.Count, 2).End(xlUp).Row, 27)) = "EOREOR"

Application.ScreenUpdating = True

End Sub

 

[DougStroud]

Like a white rabbit; magic.


thanks db!

doug