Move and Rearrange Data based on Header

[ruinedelf]

Hiya, another quandary for me. I've been able to prompt up a script that does the following:

1. Define a destination table (table 1).
2. Define a source table (table 2).
3. Move columns from table 2 to table 1 based on column header.

The script works wonderfully with one caveat: there cannot be any empty cells in table 1's header row. However, the situation I'm in requires those blank cells to be present. What would need to be modified in order to do so? Hope someone can help out!

Please see below for the script I currently have:

Sub CopyAndRearrangeData()
    Dim ws As Worksheet
    Set ws = ThisWorkbook.Sheets("ALS Import") ' Change "ALSImport" to your sheet's name
    
    ' Find the last column in row 1 of the sheet
    Dim lastColumn As Long
    lastColumn = ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column
    
    Dim table1Range As Range
    Set table1Range = ws.Range("A2").Resize(53, lastColumn) ' ws.Range (Destination Table Starting Row), Resize (# of Rows, # of Columns)
    
    Dim table2HeaderRow As Range
    Set table2HeaderRow = ws.Range("A61").Resize(1, ws.Cells(61, ws.Columns.Count).End(xlToLeft).Column) ' ws.Range (Source Table Starting Row)
    
    Dim i As Integer
    For i = 1 To table1Range.Columns.Count
        Dim header As String
        header = table1Range.Cells(1, i).Value
        
        Dim headerIndex As Long
        headerIndex = 0
        
        For Each cell In table2HeaderRow
            If cell.Value = header Then
                headerIndex = cell.Column
                Exit For
            End If
        Next cell
        
        If headerIndex > 0 Then
            Dim destColumn As Range
            Set destColumn = table1Range.Columns(i)
            
            Dim sourceColumn As Range
            Set sourceColumn = ws.Cells(61, headerIndex).Resize(ws.Cells(ws.Rows.Count, headerIndex).End(xlUp).Row - 60)
            
            ' Copy the data
            sourceColumn.Copy Destination:=destColumn.Resize(sourceColumn.Rows.Count, 1)
            destColumn.NumberFormat = "General"
            
            ' Clear the source data (Table 2)
            sourceColumn.Clear
        End If
    Next i
    
    Application.CutCopyMode = False
End Sub

 

[kevin9999]

Happy to help & thanks for the feedback

 

[ruinedelf]

Oh dangit. Early celebration.

Tried it on another set of sample data, and I'm getting a Run-time error 1004 - Unable to get the Match property of the Worksheet Function class.

I'm guessing that this error is because it's assuming that every header in the source table can be found in the destination table?

I may have forgotten to mention that sometimes, parts of the source data is not required. For instance, there may be times there's Analyte 150 in the source data, but no Analyte 150 in the destination data, because it's just not needed.

...My bad.

 

[kevin9999]

OK, replace the relevant part of the code with:

Dim i As Long
    For Each c In SrcHdr
        If WorksheetFunction.CountIf(DstHdr, c) > 0 Then
        i = WorksheetFunction.Match(c, DstHdr, 0)
            With ws.Range(Cells(62, c.Column), ws.Cells(ws.Cells(Rows.Count, c.Column).End(xlUp).Row, c.Column))
                .Copy ws.Cells(3, i)
                .Delete shift:=xlUp
            End With
        End If
    Next c

 

[ruinedelf]

This returns the same error (1004- unable to get the Match property of the WorksheetFunction class) on the following line:

i = WorksheetFunction.Match(c, DstHdr, 0)

 

[kevin9999]

It doesn't error for me when I test it on sample data - where the header in the source range doesn't exist in the destination range:
Destination

ruinedelf.xlsm
	A	B	C	D	E	F	G	H	I
1	FMP Field 1	FMP Field 2	FMP Field 3	FMP Field 4	FMP Field 5	FMP Field 6	FMP Field 7	FMP Field 8	FMP Field 9
2	Analyte 1	Analyte 2	Analyte 3	Analyte 4		Analyte 5	Analyte 6	Analyte 7	Analyte 8
3
Sheet1

Source (note Analyte 33)

ruinedelf.xlsm
	A	B	C	D	E	F
61	Analyte 5	Analyte 33	Analyte 1	Analyte 6	Analyte 7	Analyte 2
62	234	4564	64357	234	<6	23467
63	6346	324234	<4	<2	234	546890
Sheet1

After running this code:

Option Explicit
Sub Demo()
    'Get the sheet name
    Dim ws As Worksheet
    Set ws = Worksheets("Sheet1")   '<-- change as needed
    
    'Dim the range variables
    Dim SrcHdr As Range, DstHdr As Range, c As Range
    
    'Set the range variables
    Set SrcHdr = ws.Range(ws.Cells(61, 1), ws.Cells(61, ws.Rows("61").Find("*", , xlFormulas, , 2, 2).Column))
    Set DstHdr = ws.Range(ws.Cells(2, 1), ws.Cells(2, ws.Rows("2").Find("*", , xlFormulas, , 2, 2).Column))
    
    'Loop through each cell in the source header range,
    'find the matching header in the destination row,
    'and copy the data from the source to the destination
    Dim i As Long
    For Each c In SrcHdr
        If WorksheetFunction.CountIf(DstHdr, c) > 0 Then
        i = WorksheetFunction.Match(c, DstHdr, 0)
            With ws.Range(Cells(62, c.Column), ws.Cells(ws.Cells(Rows.Count, c.Column).End(xlUp).Row, c.Column))
                .Copy ws.Cells(3, i)
                .Delete shift:=xlUp
            End With
        End If
    Next c
End Sub

I get this in the destination:

ruinedelf.xlsm
	A	B	C	D	E	F	G	H	I
1	FMP Field 1	FMP Field 2	FMP Field 3	FMP Field 4	FMP Field 5	FMP Field 6	FMP Field 7	FMP Field 8	FMP Field 9
2	Analyte 1	Analyte 2	Analyte 3	Analyte 4		Analyte 5	Analyte 6	Analyte 7	Analyte 8
3	64357	23467				234	234	<6
4	<4	546890				6346	<2	234
Sheet1

Leaving this in the source:

ruinedelf.xlsm
	A	B	C	D	E	F
61	Analyte 5	Analyte 33	Analyte 1	Analyte 6	Analyte 7	Analyte 2
62		4564
63		324234
Sheet1

 

[ruinedelf]

It's still failing on my end. I created a new workbook with just the reference headers, pasted data, and the module.

Have a gander at this: LINK and see if you can reproduce it on your end?

 

[kevin9999]

I'll have to leave this until tomorrow (my time) as life's caught up.

 

[kevin9999]

Last response for the day (this worked with your latest sample)

Option Explicit
Sub CutAndRearrangeData()
    'Get the sheet name
    Dim ws As Worksheet
    Set ws = Worksheets("Sheet1")   '<-- change as needed
    
    'Dim the range variables
    Dim SrcHdr As Range, DstHdr As Range, c As Range
    
    'Set the range variables
    Set SrcHdr = ws.Range(ws.Cells(61, 1), ws.Cells(61, ws.Rows("61").Find("*", , xlFormulas, , 2, 2).Column))
    Set DstHdr = ws.Range(ws.Cells(2, 1), ws.Cells(2, ws.Rows("2").Find("*", , xlFormulas, , 2, 2).Column))
    SrcHdr.Select
    DstHdr.Select
    'Loop through each cell in the source header range,
    'find the matching header in the destination row,
    'and copy the data from the source to the destination
    Dim i As Long, rFind As Range
    For Each c In SrcHdr
        With ws.Rows("2:2")
        Set rFind = .Find(c, Lookat:=xlWhole)
        If Not rFind Is Nothing Then
        i = WorksheetFunction.Match(c, DstHdr, 0)
            With ws.Range(Cells(62, c.Column), ws.Cells(ws.Cells(Rows.Count, c.Column).End(xlUp).Row, c.Column))
                .Copy ws.Cells(3, i)
                .Delete shift:=xlUp
            End With
        End If
        End With
    Next c
End Sub

 

[ruinedelf]

I'll have to leave this until tomorrow (my time) as life's caught up.

No worries, same on my end too! Hope this doesn't turn out to be really complicated. Take care!

 

[ruinedelf]

Last response for the day (this worked with your latest sample)

Yup, this one works for what I had! I'll have to try it with some live data (and still waiting on a Mac test), but it looks promising!

Thanks again!