Excel script to organize similar data under one column

Hello Experts
I have one sheet with several thousand rows containing part measurement data.  The parts are grouped by part type. The measurement units vary from group to group, so each column contains different types of measurements.

I would like some help with a script that will organize all similar data to a single column.

I've attached some sample data.

1. If  cell in row H = "No.",  then for each vertical array between column I:N and down to the next row where H=No., copy the vertical array of values over to the matching column 0:BE

2. If cells in column M or N are emtpy, then copy text over to columns BF and BG.

3. There should be a matching column in 0:BE for all other cases. If not, return error.

Thank you!
Who is Participating?
Hi Tom, please try this.
It identifies header rows and matches them to correct columns and then processes all non-header rows below them cell by cell.
It returns an error for unmatched header cells, so you can debug or quit.
It ignores blank header cells, but reports error if a cell in the non-header rows below it have content. You can make it raise an error instead of message box by commenting line 42 and uncommenting line 43.
Examples of such errors are from rows 118 down to 125 and row 415.

Sub tf2()
Dim KeyRange As Range
Dim HeaderRange As Range
Dim MoveToCol(6) As Integer 'array to store the matching column numbers

Set KeyRange = Intersect(Range("H:H"), ActiveSheet.UsedRange)
Debug.Print KeyRange.Address
Set HeaderRange = Range("O1:BE1")

For Each c In KeyRange.Cells
    If c.Value = "No." Then
        Debug.Print "KeyRange Header ", c.Address, c.Value
        For i = 1 To 6
            findme = c.Offset(0, i).Value
            Debug.Print c.Offset(0, i).Address, "|" & findme & "|";
            Set matchresult = HeaderRange.Find(what:=findme, lookat:=xlWhole)
            If Not matchresult Is Nothing Then
                Debug.Print vbTab, matchresult.Address
                MoveToCol(i) = matchresult.Column
            ElseIf c.Offset(0, i) = "" And i = 5 Then
                Debug.Print vbTab, 58 & "(BF)"
                MoveToCol(i) = 58 'BF
            ElseIf c.Offset(0, i) = "" And i = 6 Then
                Debug.Print vbTab, 59 & "(BG)"
                MoveToCol(i) = 59 'BG
            Else 'no match for the header column title was found. This is ok if in cols 5&6, but not in 1-4.
                Debug.Print "Not found"
                MoveToCol(i) = 0
                If findme <> "" Then 'only raise error if header cell is non-blank. For blank headers, the content of the column will be checked row by row
                    Err.Raise vbObjectError + 1, "", "No match for header in cell " & c.Offset(0, i).Address & " with value " & c.Offset(0, i).Value
                End If
            End If
        Next i
    ElseIf c.Row = 1 Then
        'skip header row (I was just to lazy to define the range more accurately
        Debug.Print "KeyRange Content", c.Address, c.Value
        For i = 1 To 6
            If c.Offset(0, i).Value <> "" Then
                If MoveToCol(i) = 0 Then
                    Debug.Print "No match for header of cell " & c.Offset(0, i).Address & " with value " & c.Offset(0, i).Value
                    If MsgBox("No match for header of cell " & c.Offset(0, i).Address & " with value " & c.Offset(0, i).Value, vbOKCancel) = vbCancel Then Exit Sub Else
                    'Err.Raise vbObjectError + 1, "", "No match for header of cell " & c.Offset(0, i).Address & " with value " & c.Offset(0, i).Value
                    Debug.Print "Cell " & Cells(c.Row, MoveToCol(i)).Address & " will receive value from " & c.Offset(o, i).Address
                    Cells(c.Row, MoveToCol(i)).Value = c.Offset(0, i).Value
                End If 'MoveTo
            End If 'cell value <>""
        Next i
    End If
Next c
MsgBox "Finished"
End Sub

Open in new window

u need vba I guess ?
Is this a 1 time or repetitive ?
tomfolinsbeeAuthor Commented:
one time only. Thanks for your interest!
Introducing Cloud Class® training courses

Tech changes fast. You can learn faster. That’s why we’re bringing professional training courses to Experts Exchange. With a subscription, you can access all the Cloud Class® courses to expand your education, prep for certifications, and get top-notch instructions.

you say Copy block I:N till you hit the first No
to O:BE

I:N = 6 columns
O:BE = 31 columns

so if we copy will be
first block O:T
second block U:Z
last block finishes at column BD
and Be will be blank !!!

is this correct ?
tomfolinsbeeAuthor Commented:
Idea is to copy each column in I:N separetely over to the column in O:BE with the matching header (measurement unit).

Matching header !!!! ???? You are kidding it is in chineese !
Hi, I gave you a solution to your last one, Tom, and am working on one for this. I expect to have something for you in the next few hours (after family time).
@gowflow: for the last one I did unicode character code matching, but this one is a little easier in some ways.
good luck then Simon I will leave you to handle translation as not into this.
tomfolinsbeeAuthor Commented:
Thanks for this.  Would you mind modifying so that there no labels in the top tow to start, and new labels are added whenever a new label  is encountered will the script is looping through? I created the top row labels using excel remove duplicates, but could have missed some or perhaps ilchanged encoding???

Really appreciate your help with this!
Hi Tom, with respect, that's a new request. This solution was based on matching to an existing range of headers and writing to fixed pair of column if M:N headers were blank. I'll happily help if you sign this one off and ask a new question, but this has taken enough time to solve, and what you're asking now seems like a significant change of scope.

Out of interest are you asking because you found lots of unmatched headers when you ran the code above on your live data?
How many rows of live data do you have to go through?
tomfolinsbeeAuthor Commented:
Thanks simon!

About 3000 rows.

I understand the error messages now. The data looks fine.

Thanks for your efforts on this!
tomfolinsbeeAuthor Commented:
Thanks your help with this!
tomfolinsbeeAuthor Commented:

I've created a new question
1) error around record 600 in the full recordset
2) request to automatically generate new labels in top row

Question has a verified solution.

Are you are experiencing a similar issue? Get a personalized answer when you ask a related question.

Have a better answer? Share it in a comment.

All Courses

From novice to tech pro — start learning today.