Results 1 to 3 of 3

Add Constant Value to Worksheet w/ VBA

This is a discussion on Add Constant Value to Worksheet w/ VBA within the Excel Questions forums, part of the Question Forums category; I have to add constants to a worksheet with the use of VBA . Column "X" will need the term ...

  1. #1
    Board Regular
    Join Date
    Aug 2005
    Posts
    2,878

    Default Add Constant Value to Worksheet w/ VBA

    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:
    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

  2. #2
    Board Regular dbmathis's Avatar
    Join Date
    Sep 2002
    Location
    Austin, Texas USA
    Posts
    1,064

    Default

    Is this what you wanted?

    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
    
    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
    After all this is over, all that will really have mattered is how we treated each other.

    Excel Version: 2007
    OS: Windows 7

  3. #3
    Board Regular
    Join Date
    Aug 2005
    Posts
    2,878

    Default

    Like a white rabbit; magic.


    thanks db!

    doug
    my site: www.ecboardco.com
    was built w/ a tremendous amount of help and guidance from mrexcel and a few dedicated board members: A Huge Thanks!

Like this thread? Share it with others

Like this thread? Share it with others

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •  


DMCA.com