VBA - Only paste the whole columns of the array in the targetsheet if there is a matching header.

[Bassie]

Hi,

In my code I created a custom array of a raw data sheet (temp) with about 50 columns. My targetsheet where I want to paste this data has only around 15 columns and not all the columns in the targetsheet are in the raw data sheet. I only want to paste the values from my array in the datasheet if there is a matching header. Or maybe better (faster) to not make the array out of all the columns in the raw data sheet but only of the columns that are also available in the targetsheet.

Dim Temp As Worksheet
Dim data As Variant, newData As Variant
Dim i As Long, j As Long

Set Temp = Sheets("Temp")

Set dataRange = Temp.Range("A1").CurrentRegion
lastRow = dataRange.Rows.Count

' read data into an array (excluding headers)
data = dataRange.Offset(1, 0).Resize(lastRow - 1).Value
    
' filter data
ReDim newData(1 To UBound(data), 1 To UBound(data, 2))
j = 1

'This For loop will add every row into a new array (newdata) when a few IF's are not met
'If the IFS are met then the row will not be added to the new array and thus will not be visable in the target sheet
For i = 1 To UBound(data)
    'If any of these things is true, skip the row. I hid the XX as it is condifential but It should not matter.
    If <XX> Then
        ElseIf <XX> Then
            ElseIf <XX> Then
                ElseIf <XX> Then
    Else
            For k = 1 To UBound(data, 2)
                newData(j, k) = data(i, k)
            Next k
            j = j + 1
    End If
Next i

' clear original data and write new data to the worksheet (including headers)
' In future I want this to the targetsheet with only the correct headers
dataRange.Offset(1, 0).Resize(lastRow - 1).ClearContents
dataRange.Offset(1, 0).Resize(j - 1).Value = newData

Is this possible?

Regards,
Bassie

 

[Herakles]

Anything is possible.

Try this procedure, subCopyColumnsOfDataToAnotherWorksheet, that I coded a while ago.

All you have to do is pass it the source and destination worksheet objects and the list of column headers in the array.

If you don't need the messages at the end you can delete them.

What do want to do if the column header is not found?

Public Sub subTest()
Dim strHeaders As Variant
Dim WsSource As Worksheet
Dim WsDestination As Worksheet
Dim arrHeaders() As String

    ActiveWorkbook.Save

    ' Set the name of the source worksheet.
    Set WsSource = Worksheets("SampleNamesAndAddresses")
    
    ' Set the name of the destination worksheet.
    Set WsDestination = Worksheets("Destination")
    
    ' Headers of columns to copy.
    strHeaders = "first_name,last_name,company_name,Address,city,county,State,zip,phone1,phone2,Email,web"
    
    ' Clear contents in the destination sheet.
    WsDestination.Range("A2").Resize(Rows.Count - 1, Columns.Count).ClearContents
        
    arrHeaders = Split(strHeaders, ",")
    
    Call subCopyColumnsOfDataToAnotherWorksheet(WsSource, WsDestination, arrHeaders())
    
End Sub

Public Sub subCopyColumnsOfDataToAnotherWorksheet(WsSource As Worksheet, WsDestination As Worksheet, ByVal arrHeaders As Variant)
Dim i As Integer
Dim rngFound As Range
Dim rng As Range
Dim strMissing As String
Dim strFound As String

    With WsSource
    
        For i = LBound(arrHeaders) To UBound(arrHeaders)
                
                Set rngFound = WsDestination.Range("A1").CurrentRegion.Rows(1).Find(arrHeaders(i), LookIn:=xlValues, LookAt:=xlWhole)
                
                If Not rngFound Is Nothing Then
                                              
                    rngFound.Offset(1, 0).Resize(.Range("A1").Offset(0, i).End(xlDown).Row, 1).Value = _
                        .Range("A1").Offset(1, i).Resize(.Range("A1").Offset(0, i).End(xlDown).Row, 1).Value
                
                    strFound = strFound & vbCrLf & arrHeaders(i)
                    
                Else
                    
                    strMissing = strMissing & vbCrLf & arrHeaders(i)
                
                End If
                
            Next i
    
    End With
    
    If strFound <> "" Then
        MsgBox "Data from the following columns has been copied to the '" & WsDestination.Name & "' worksheet." & _
            vbCrLf & strFound, vbInformation, "Confirmation."
    End If

    If strMissing <> "" Then
        MsgBox "The following columns have not been found in the '" & WsDestination.Name & "' worksheet." & _
            vbCrLf & strMissing, vbInformation, "Warning!"
    End If
    
End Sub