VBA needs some help please!! Not sure why my coding is not correct!! Copy and paste columns based on conditions

[nevers711]

Hello everyone,

I wrote some Macros and would like it to help me copy and paste the entire columns based on the header.

Sheet1 is the source data, and I would like Macros to help me copy the entire column if the headers are "PO #", "Vendor Name", "Service Start Date", "Service End Date", and "Outstanding amount" from sheet 1 to sheet2. Here is my code:



Sub Macro1()
'
' Macro1 Macro
'
Dim j As Long
For j = 1 To 100
Sheets("Sheet1").Activate
If Sheets("Sheet1").Cells(1, j) = "PO #" Or Sheets("Sheet1").Cells(1, j) = "PO#" Or Sheets("Sheet1").Cells(1, j) = "PO Number" Then Sheets("Sheet1").Cells(1, j).Select
Selection.EntireColumn.Copy
Sheets("Sheet2").Select
Range("A1").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Next j

Dim k As Long
For k = 1 To 100
Sheets("Sheet1").Activate
If Sheets("Sheet1").Cells(1, k) = "Vendor Name" Then Sheets("Sheet1").Cells(1, k).Select
Selection.EntireColumn.Copy
Sheets("Sheet2").Select
Range("B1").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Next k

Dim i As Long
For i = 1 To 100
Sheets("Sheet1").Activate
If Sheets("Sheet1").Cells(1, i) = "service start date" Then Sheets("Sheet1").Cells(1, i).Select
Selection.EntireColumn.Copy
Sheets("Sheet2").Select
Range("C1").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Next i

Dim m As Long
For m = 1 To 100
Sheets("Sheet1").Activate
If Sheets("Sheet1").Cells(1, m) = "service end date" Then Sheets("Sheet1").Cells(1, m).Select
Selection.EntireColumn.Copy
Sheets("Sheet2").Select
Range("D1").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Next m

Dim n As Long
For n = 1 To 100
Sheets("Sheet1").Activate
If Sheets("Sheet1").Cells(1, n) = "Outstanding Amount" Then Sheets("Sheet1").Cells(1, n).Select
Selection.EntireColumn.Copy
Sheets("Sheet2").Select
Range("E1").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Next n



End Sub


Every time I run it, it incorrectly copied and pasted "Vendor Name" column to "service start date" & "service end date" columns.. Does anybody know why? I double checked and I am pretty sure I didn't spell anything wrong and all the service start or end dates are there in sheet1. Also, can anybody help me improve these codes since I think it is pretty slow to run.. Thank you so much!

 

[Micron]

Can't see your sheet columns but can say that since you're looping out to 100, if any header satisfies the test after the first copied column is found, it will do it again at the position of whatever your counter is. Not sure why you'd pick 100 instead of the last column that has a value in row 1 (assuming row 1 is the header row) but changing that won't stop the repeat copy/paste if that's what your problem is. To fix that, I'd say when the IF block is executed because the test was True, exit the loop with Exit For.
You could step through this code and see if I've pinpointed the problem. If so, you'll get more than one execution of the IF block for a column header that is the same as one already copied.

When posting code, please use code tags and proper indentation (use vba button on posting toolbar).

EDIT - re "can't see your columns" - OOPS. I forgot to look at your attachment. Then again, can't tell if that's what was or is what you ended up with.
As for improving the code, repost in code tags for the practice and I'll take a closer look. At the very least, you'd want to take the Activate method outside of the loops?

 

[mumps]

Try:

Sub CopyData()
    Application.ScreenUpdating = False
    Dim LastRow As Long, srcWS As Worksheet, desWS As Worksheet, v As Variant, i As Long, fnd As Range
    Set srcWS = Sheets("Sheet1")
    Set desWS = Sheets("Sheet2")
    LastRow = Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    v = Array("PO", "Vendor Name", "service start date", "service end date", "Outstanding Amount")
    For i = LBound(v) To UBound(v)
        Set fnd = srcWS.Rows(1).Find(v(i), LookIn:=xlValues, lookat:=xlPart)
        If Not fnd Is Nothing Then
            srcWS.Cells(1, fnd.Column).Resize(LastRow).Copy desWS.Cells(1, i + 1)
        End If
    Next i
    Application.ScreenUpdating = True
End Sub

 

[rlv01]

Another alternative

Sub Macro1()
    '
    ' Macro1 Macro
    '
    Dim j As Long, Ofs As Long
    Dim WS1 As Worksheet, WS2 As Worksheet
    
    Set WS1 = Worksheets("Sheet1")
    Set WS2 = Worksheets("Sheet2")
    For j = 1 To 100
        Ofs = 999
        Select Case UCase(Trim(WS1.Cells(1, j).Value))
            Case "PO #", "PO#", "PO NUMBER"
                Ofs = 0
            Case "VENDOR NAME"
                Ofs = 1
            Case "SERVICE START DATE"
                Ofs = 2
            Case "SERVICE END DATE"
                Ofs = 3
            Case "OUTSTANDING AMOUNT"
                Ofs = 4
        End Select
        If Ofs <> 999 Then
            Application.Intersect(WS1.Cells(1, j).EntireColumn, WS1.UsedRange).Copy
            WS2.Range("A1").Offset(0, Ofs).PasteSpecial Paste:=xlPasteValues
            WS2.UsedRange.Columns.AutoFit
        End If
    Next j
End Sub

 

[nevers711]

OMG!! Thank you so much guys!! Both of your codes work!! I selected rlv01's his codes as answer since it is easier for me to understand.. Sorry I only have limited knowledge, but I can tell mumps' codes are very concise and efficient. Thank you!!!

 

[nevers711]

Another alternative

Sub Macro1()
    '
    ' Macro1 Macro
    '
    Dim j As Long, Ofs As Long
    Dim WS1 As Worksheet, WS2 As Worksheet
  
    Set WS1 = Worksheets("Sheet1")
    Set WS2 = Worksheets("Sheet2")
    For j = 1 To 100
        Ofs = 999
        Select Case UCase(Trim(WS1.Cells(1, j).Value))
            Case "PO #", "PO#", "PO NUMBER"
                Ofs = 0
            Case "VENDOR NAME"
                Ofs = 1
            Case "SERVICE START DATE"
                Ofs = 2
            Case "SERVICE END DATE"
                Ofs = 3
            Case "OUTSTANDING AMOUNT"
                Ofs = 4
        End Select
        If Ofs <> 999 Then
            Application.Intersect(WS1.Cells(1, j).EntireColumn, WS1.UsedRange).Copy
            WS2.Range("A1").Offset(0, Ofs).PasteSpecial Paste:=xlPasteValues
            WS2.UsedRange.Columns.AutoFit
        End If
    Next j
End Sub

Hello, I was trying to add more conditions based on your code, but it doesn't work. Could you please let me know why? This is the code I wrote. I would like to add "Currency" as the sixth column (Case "Currency" ofs = 5), but it didn't copy and paste over.. Thank you so much if you can clarify

Sub Macro1()
    '
    ' Macro1 Macro
    '
    Dim j As Long, Ofs As Long
    Dim WS1 As Worksheet, WS2 As Worksheet
  
    Set WS1 = Worksheets("Sheet1")
    Set WS2 = Worksheets("Sheet2")
    For j = 1 To 100
        Ofs = 999
        Select Case UCase(Trim(WS1.Cells(1, j).Value))
            Case "PO #", "PO#", "PO NUMBER"
                Ofs = 0
            Case "VENDOR NAME"
                Ofs = 1
            Case "SERVICE START DATE"
                Ofs = 2
            Case "SERVICE END DATE"
                Ofs = 3
            Case "OUTSTANDING AMOUNT"
                Ofs = 4           
            Case "Currency"
                Ofs = 5
        End Select
        If Ofs <> 999 Then
            Application.Intersect(WS1.Cells(1, j).EntireColumn, WS1.UsedRange).Copy
            WS2.Range("A1").Offset(0, Ofs).PasteSpecial Paste:=xlPasteValues
            WS2.UsedRange.Columns.AutoFit
        End If
    Next j
End Sub

 

[rlv01]

Hello, I was trying to add more conditions based on your code, but it doesn't work. Could you please let me know why? This is the code I wrote. I would like to add "Currency" as the sixth column (Case "Currency" ofs = 5), but it didn't copy and paste over.. Thank you so much if you can clarify[

It needs to be Case "CURRENCY" (upper case). Any new condition you add needs to be upper case.

 

[nevers711]

It needs to be Case "CURRENCY" (upper case). Any new condition you add needs to be upper case.

Thank you so much!!! It works!!