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

Bassie

Board Regular
Joined
Jan 13, 2022
Messages
66
Office Version
  1. 2019
Platform
  1. Windows
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.

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

Excel Facts

Copy PDF to Excel
Select data in PDF. Paste to Microsoft Word. Copy from Word and paste to Excel.
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?

VBA Code:
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
 
Upvote 0

Forum statistics

Threads
1,223,164
Messages
6,170,444
Members
452,326
Latest member
johnshaji

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top