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]

Is there any chance of posting your sheet using the XL2BB add in, or alternatively, sharing your file via Google Drive, Dropbox or similar file sharing platform? A before and after demonstration would be ideal.

 

[ruinedelf]

Here's a link! <Will be deleted 6 days from this post>

It's quite complicated and complex, a lot of scripts running. Most likely not optimal, but I have no experience of scripting and mostly just prompted up the scripts using AI. Does what I need it to do though!

The script in question is Module 3.

 

[kevin9999]

Thank you for that, and I must apologise because I cannot fathom the labyrinth of 10 modules and 2 class modules to determine exactly what your end objective is. A before and after would have been ideal.
Could you explain, as simply as possible, precisely what it is that you're trying to achieve via the code.
As an aside, if this is what AI has provided you then I'm glad I avoid it like the plague...

 

[ruinedelf]

To be fair to AI, I basically went step by step. Rather than tell it what I want it to do in one fell swoop, I divided up the final result into a series of steps that I'd need to do to reach it, then asked AI to make scripts for each step, which are in the modules. The Changelog tab has said step by step, with each module being a single step. I could, of course, have rearranged everything and made it look a lot neater. A single module, with all sub modules arranged chronologically, etc. I never figured that I'd be uploading the file online, so it's basically there warts and all.

In a nutshell, the idea is to be able to take the Test Import Data (which naturally would be live data in production), copy that, and paste it under the black line (starting at A61) in the Import Script. Clicking the button would then take care of all the processing in the background, which would spit out a CSV file that can be imported into FileMaker Pro.

What this particular topic is about is the moving and rearranging part. I'm going to try and make an example here:

Before:
Table 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
Analyte 1	Analyte 2	Analyte 3	Analyte 4		Analyte 5	Analyte 6	Analyte 7	Analyte 8

Table 2:

Analyte 5	Analyte 3	Analyte 1	Analyte 6	Analyte 7	Analyte 2
234	4564	64357	234	<6	23467
6346	324234	<4	<2	234	546890

After:
Table 3:

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
Analyte 1	Analyte 2	Analyte 3	Analyte 4		Analyte 5	Analyte 6	Analyte 7	Analyte 8
64357	23467	4564			234	234	<6
<4	546890	324234			6346	<2	234

Table 2 is the data that would've been pasted, note that there are no FMP Field headers. The script should then move the data from Table 2 to Table 1, matching row 2 in Table 1 with the header row of Table 2.

Hope that made more sense!

 

[ruinedelf]

Oh, and I should probably mention that the workbook needs to be OS agnostic: It needs to be able to work on both Windows and Mac, which is why the Class Modules are there. Mac does not have access to Microsoft Scripting Runtime, but (two of) the scripts I have rely on Dictionaries, so I had to compensate for that.

 

[kevin9999]

OK, I'll have to pull out here as I have zero experience in writing code for Mac's. But what I can do is provide a demonstration of how I would approach the realigning problem using your sample data as an example. Obviously you need to change the cell references/sheet name to suit your particular needs.
So starting with this:

Book1
	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
4
5
6
7
8
9
10	Analyte 5	Analyte 3	Analyte 1	Analyte 6	Analyte 7	Analyte 2
11	234	4564	64357	234	<6	23467
12	6346	324234	<4	<2	234	546890
Sheet1

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(10, 1), ws.Cells(10, ws.Rows("10").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
        i = WorksheetFunction.Match(c, DstHdr, 0)
        If i > 0 Then
            ws.Range(Cells(11, c.Column), ws.Cells(ws.Cells(Rows.Count, c.Column).End(xlUp).Row, c.Column)).Copy ws.Cells(3, i)
        End If
    Next c
End Sub

Produces this:

Book1
	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	4564			234	234	<6
4	<4	546890	324234			6346	<2	234
5
6
7
8
9
10	Analyte 5	Analyte 3	Analyte 1	Analyte 6	Analyte 7	Analyte 2
11	234	4564	64357	234	<6	23467
12	6346	324234	<4	<2	234	546890
Sheet1

Sorry I couldn't be of any more help, but hopefully someone will come forward to assist further. Best wishes & good luck with your project.

 

[ruinedelf]

I think you're on the right track, a few modifications and it might work! From what I can see, scripting in Mac and Windows aren't that different at the basic level, which I presume this is (relatively speaking).

First of all, as the source table starts on row 61, I went in and changed everything that said "10" in the SrcHdr line to "61", as well as changing "11" to "62" in the ws.Range part near the end. The script runs without issue, now to adjust the output a bit!

This was the input:

Batch	Sample	SLUDGE Arsenic mg/kg	SLUDGE Boron mg/kg	SLUDGE Cadmium mg/kg	SLUDGE Chromium mg/kg	SLUDGE Copper mg/kg	SLUDGE Electrical Conductivity @ 25°C µS/cm	SLUDGE Lead mg/kg	SLUDGE Mercury mg/kg	SLUDGE Moisture Content %	SLUDGE Nickel mg/kg	SLUDGE pH Value pH Unit	SLUDGE Selenium mg/kg	SLUDGE Total Nitrogen as N mg/kg	SLUDGE Styrene mg/kg	SLUDGE Vinyl benzene mg/kg
66624	TGTW Week 4 01/12/23 - 66624 : 1	<0.1	<5	<0.1	2.3	30.6		1.6	<0.1		0.7		<1		12.9
66624	TGTW Week 4 01/12/23 - 66624 : 1						401			59.9		4		4050
66624	Composite TGTW - 01/12/23 - 66624 :2	<0.1	<5	<0.1	2.7	24.4		2	<0.1		0.7		<1			16.1
66624	Composite TGTW - 01/12/23 - 66624 :2						377			57.5		4.1		5190

This is what it looks like now after running the script:

Batch_ID	Sample_ID	.:::SOLIDS:::.	.::General::.	pH_in_H2O_EXT	EC_uScm_EXT	EC_dSm	N_total_pc	N_total_mgkg	TKN_mgkg	S_total_mgkg	S_total_pc	P_digest_EXT_mgkg	P_digest_EXT_pc	MC_WaterRatio_ext_pc	MC_SolidsRatio_ext_pc	SOUR_mgO2g	OilAndgrease_mgkg
Batch	Sample	.:::SOLIDS:::.	.::General::.	pH Value pH Unit	Electrical Conductivity @ 25°C µS/cm			Total Nitrogen as N mg/kg		Sulfur as S mg/kg	Sulfur - Total as S (LECO) %	Phosphorus mg/kg		Moisture Content %			Oil and Grease mg/kg
28-May-82	1			4	401			4050					59.9	59.9
28-May-82	2			4.1	377			5190					57.5	57.5

Which is really close to what I need! (If you're worried about 4 rows becoming 2, don't worry, that's a script I have that merges rows if there's a duplicate sample name) Just two things:

1) If you compare the source and destination, the source's numbers seem to have been converted to dates in the destination. Is there any way to avoid that?

2) Additionally, would it be too difficult to delete whatever has been successfully moved? Cut and paste rather than copy, if you will.

That should honestly be it, I'll just need to get onto a Mac and give it a trial run after we've got it ironed out!

 

[kevin9999]

If you compare the source and destination, the source's numbers seem to have been converted to dates in the destination. Is there any way to avoid that?

The code doesn't do that. It has to be the destination cell format. (Dates are just numbers - and 66624 is actually 28 May 2082.) Check your destination cell formats, and make sure no other code is converting the format of those cells to dates.

would it be too difficult to delete whatever has been successfully moved?

Not a problem, just change this:

ws.Range(Cells(62, c.Column), ws.Cells(ws.Cells(Rows.Count, c.Column).End(xlUp).Row, c.Column)).Copy ws.Cells(3, i)

To this:

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

 

[ruinedelf]

Alrighty, found the issue, the source data is formatted as "Date", despite still showing up as the numbers I need. Copy-pasting it into the XLSM file didn't change its format, but using a script to copy/move it around forced it back. I prompted up a script to find the appropriate column and change the format of every populated cell in it to General, issue resolved!

Now the only thing left is to try it on a Mac. If it works, I'm happy to close this off! Thanks so much for your help, Kevin!