VBA Help to find a column based on header value and cupy it to an other worksheet-CodePudding

I have this basic code to find the needed coumns in a table and copy them to an other worksheet. My problem is that every time I want to modify it to not to copy&paste the header it returns error. This is my code:

Sub CopyColumns()

    Dim wsSource, wsResult As Worksheet
    Dim Name, UniqueId, OperatingStatus As Long
       
    Set wsSource = ThisWorkbook.Sheets("Source")
    Set wsResult = ThisWorkbook.Sheets("Result")
    
    Name = wsSource.Rows(1).Find("#BASEDATA#name").Column
    UniqueId = wsSource.Rows(1).Find("#BASEDATA#uniqueId").Column
    OperatingStatus = wsSource.Rows(1).Find("#BASEDATA#operatingStatus").Column
    
    If Name <> 0 Then
        wsSource.Columns(Name).Copy Destination:=wsResult.Columns(3)
    End If
    If UniqueId <> 0 Then
        wsSource.Columns(UniqueId).Copy Destination:=wsResult.Columns(4)
    End If
    If OperatingStatus <> 0 Then
        wsSource.Columns(OperatingStatus).Copy Destination:=wsResult.Columns(1)
    End If
    
End Sub

Any ideas how to solve it? I tried is to copy like this using offset:

If targetColName <> 0 Then
wsSource.Columns(targetColName).Offset(1, 0).Resize(wsSource.Rows.Count - 1).Copy _ Destination:=wsResult.Columns(3).Offset(1, 0)

It gives Error: Application-defined ot object-defined error

Thanks!

offset and resize not working

CodePudding user response：

You can break out the "copy column if found" into a separate sub:

Sub CopyColumns()

    Dim wsSource, wsResult As Worksheet
    
    Set wsSource = ThisWorkbook.Sheets("Source")
    Set wsResult = ThisWorkbook.Sheets("Result")
    
    CopyIfExists wsSource.Rows(1), "#BASEDATA#name", wsResult, 3
    CopyIfExists wsSource.Rows(1), "#BASEDATA#uniqueId", wsResult, 4
    CopyIfExists wsSource.Rows(1), "#BASEDATA#operatingStatus", wsResult, 1
    
End Sub

'Look for `colName` in `headerRow`, and if found copy the whole
'  column to column `destColNum` on `destSheet`
Sub CopyIfExists(headerRow As Range, colName As String, destSheet As Worksheet, destColNum As Long)
    Dim f As Range
    Set f = headerRow.Find(what:=colName, lookat:=xlWhole) 'or xlPart
    If Not f Is Nothing Then
        f.EntireColumn.Copy destSheet.Cells(1, destColNum)
    End If
End Sub

When using find, you should check you got a match before trying to do anything with the matched cell.

CodePudding user response：

Copy Columns

Option Explicit

Sub CopyColumnsToResult()

    Dim sColNames(): sColNames = Array("#BASEDATA#name", _
        "#BASEDATA#uniqueId", "#BASEDATA#operatingStatus")
    Dim dCols(): dCols = Array(3, 4, 1)

    Dim sws As Worksheet: Set sws = ThisWorkbook.Sheets("Source")
    Dim shrg As Range: Set shrg = sws.Rows(1)
    Dim slCell As Range: Set slCell = shrg.Cells(shrg.Cells.Count) ' last cell
    
    Dim dws As Worksheet: Set dws = ThisWorkbook.Sheets("Result")
    
    Dim shCell As Range, c As Long
    
    For c = LBound(sColNames) To UBound(sColNames)
        Set shCell = shrg.Find(sColNames(c), slCell, xlFormulas, xlWhole)
        If Not shCell Is Nothing Then ' header cell found
            sws.Columns(shCell.Column).Copy dws.Columns(dCols(c))
        End If
    Next c
    
    MsgBox "Columns copied.", vbInformation
    
End Sub