Copy And Paste Data Matching

Question

I have FileA with raw data. The blue cells are headers, labelled A-J. The peach colored cells represent the data, which is typically text that varies and is not constant and are labelled 1-10.

File A:

enter image description here

File B:

enter image description here The second sheet contains the headers in blue as described above.

I have been unable to write a vba code to match the specified header to a column and paste the subsequent data below in the next available cell. I.e. (A1,A5,A8,A11,A14,A17 are matched to their respective header and pasted into the second sheet in A2,A3,A4,A5,A6,A7)

You'll notice that in the raw data it is not completely constant, Rows 4-5, 10-12, 13-14 are missing data for column F making it harder to match in a large data set.

the current code that come close to helping but doesnt work is posted below:

Dim wbk As Workbook
Set wbk = ThisWorkbook
Set ws = wbk.Sheets(1)
Set ws2 = wbk.Sheets(2)
Dim cell As Range
Dim refcell As Range

Application.ScreenUpdating = False
ws.Select

    For Each cell In ws.Range("A1:Z1")

        cell.Activate
        ActiveCell.Offset(1, 0).Copy

        For Each refcell In ws2.Range("A1:Z1")
            If refcell.Value = cell.Value Then refcell.Paste
        Next refcell

    Next cell
    Application.ScreenUpdating = False

Addition:

    Dim wbk As Workbook
Set wbk = ThisWorkbook
Set ws = wbk.Sheets(1)
Set WS2 = wbk.Sheets(2)
Dim cell As Range
Dim refcell As Range
Dim Col As Long

Application.ScreenUpdating = False
ws.Select

    For Each cell In ws.Range("A1:Z15000")

        cell.Activate
        Col = Application.WorksheetFunction.Match(WS2.Range("Cell").Value.Rows("1:1"), False)

        For Each refcell In WS2.Range("A1:Z1")
            Cells(Rows.Count, Col).End(xlUp).Offset(1, 0).Resize(Rng.Rows.Count).Value = Rng.Value
        Next refcell

    Next cell
Application.ScreenUpdating = True

Show source
| excel-vba   | vba   | excel   | copy-paste   2017-01-06 22:01 1 Answers

Answers to Copy And Paste Data Matching ( 1 )

  1. 2017-01-07 10:01

    you can go the other way around:

    Option Explicit
    
    Sub main()
        Dim hedaerCell As Range
        Dim labelsArray As Variant
    
        With ThisWorkbook.Worksheets("Sheet02") '<--| reference your "headers" worksheet
            For Each hedaerCell In .Range("A1:J1") '<--| loop through all "headers"
                labelsArray = GetValues(hedaerCell.value) '<--| fill array with all labels found under current "header"
                .Cells(.Rows.Count, hedaerCell.Column).End(xlUp).Offset(1).Resize(UBound(labelsArray)).value = Application.Transpose(labelsArray) '<--| write down array values from current header cell column first not empty cell
            Next
        End With
    End Sub
    
    Function GetValues(header As String) As Variant
        Dim f As Range
        Dim firstAddress As String
        Dim iFound As Long
    
        With ThisWorkbook.Worksheets("Sheet01").UsedRange '<--| reference your "data" worksheet
            ReDim labelsArray(1 To WorksheetFunction.CountIf(.Cells, header)) As Variant '<--| size an array to store as many "labels" as passed 'header' occurrences
            Set f = .Find(what:=header, LookIn:=xlValues, lookat:=xlWhole) '<--| start seraching for passed 'header'
            If Not f Is Nothing Then
                firstAddress = f.Address
                Do
                    iFound = iFound + 1
                    labelsArray(iFound) = f.Offset(1)
                    Set f = .FindNext(f)
                Loop While f.Address <> firstAddress
            End If
        End With
        GetValues = labelsArray
    End Function
    

Leave a reply to - Copy And Paste Data Matching

◀ Go back