VBA or Excel formula to re-order data and removes blank columns

H

hunghung

New Member
Joined
Feb 27, 2018
Messages
24
Office Version
  1. 365
  2. 2016
Platform
  1. Windows
I have a PO in pdf, i converted it to Excel format. However, data in Excel file is mixed and many blank cells and columns. Here below are my original excel file and target result that I want.
Please help me with VBA or excel formula to solve this. Thank in advance.

Target results:
P.OStyleColorSMLXLXXL
38154MF25XK77BLUNAR72536248
38154MF25XK77BOSGRY2070986621
38154MF25XK77BSHW1551714815
..........................................................................

Data on original Excel file.
P.O. NUMBER38154
MF25XK77B
Color S M L XL XXL
LUNAR 7 25 36 24 8
OSGRY 20 70 98 66 21
SHW 15 51 71 48 15
P.O. NUMBER38155
MF25XK77B
Color S M L XL XXL
LUNAR 18 112 161 106 28
OSGRY 11 66 95 62 16
SHW 15 85 123 80 22
P.O. NUMBER38177
LF25EB18
Color XS S M L XL
MSPCE 8 20 21 10 4
WHT 10 24 25 12 4
MF25EK45
Color S M L XL XXL
BLHZE 72 255 350 220 78
NPINE 43 153 210 132 47
SKY 63 214 301 191 71
MF25EK45A
Color S M L XL XXL
ETIDE 18 64 87 55 20
MF25EK45B
Color S M L XL XXL
ETIDE 43 153 210 132 47
NAV 36 128 174 110 39
MF25EK45C
Color S M L XL XXL
SNV 29 102 140 88 31
P.O. NUMBER38177
MF25EK50S
Color S M L XL XXL
ETIDE 34 122 158 95 32
SEAPT 19 68 86 53 18
MF25EK51S
Color S M L XL XXL
SEAPT 10 37 49 29 10
TNGO 9 34 41 26 9
MF25EK52S
Color S M L XL XXL
ETIDE 11 39 51 32 11
MF25EK54S
Color S M L XL XXL
WHT 9 29 37 24 8
MF25EK55S
Color S M L XL XXL
SEAPT 13 47 62 37 13
MF25EK56S
Color S M L XL XXL
P.O. NUMBER38177
ETIDE 14 50 64 40 14
SEAPT 18 64 84 50 17
MF25XK01E
Color S M L XL XXL
BLUTZ 22 77 99 59 18
MF25XK02E
Color S M L XL XXL
DOG 41 130 155 86 31
 
Sort by date Sort by votes
Give this a shot. Open a COPY of your workbook. Press Alt-F11 to open the VBA editor. Press ALT-IM to Insert a Module. Paste the following code into the window that opens:

VBA Code: 
Sub ReOrg()
Dim InputLoc As Range, OutputLoc As Range
Dim lr As Long, InRow As Long, OutRow As Long
Dim po As String, style As String, sizes As Object
Dim c As Long, ci As Long, co As Long, work As Long, x As Variant


    Set InputLoc = Sheets("Sheet1").Range("A1")
    Set OutputLoc = Sheets("Sheet2").Range("A1")
    
    lr = InputLoc.End(xlDown).Row
    OutputLoc.Resize(lr * 2, 10).ClearContents
    OutputLoc.Resize(lr * 2, 10).Interior.Color = xlNone
    
    OutputLoc.Resize(, 9) = Array("P.O.", "Style", "Color", "XS", "S", "M", "L", "XL", "XXL")
    InRow = 0
    OutRow = 0
    
    While InputLoc.Offset(InRow, 0) <> ""
        If InputLoc.Offset(InRow, 0) = "P.O. NUMBER" Then
            po = InputLoc.Offset(InRow, 1)
            style = ""
            Set sizes = Nothing
        End If
        
        If InputLoc.Offset(InRow, 0) = "Color" Then
            Set sizes = CreateObject("Scripting.Dictionary")
            For c = 2 To 30
                If InputLoc.Offset(InRow, c) <> "" Then
                    sizes(CStr(InputLoc.Offset(InRow, c))) = c
                End If
            Next c
        End If
        
        work = WorksheetFunction.CountA(InputLoc.Offset(InRow, 2).Resize(, 30))
        If work = 0 Then
            If InputLoc.Offset(InRow, 0) <> "P.O. NUMBER" Then style = InputLoc.Offset(InRow, 0)
        Else
            If InputLoc.Offset(InRow, 0) <> "Color" Then
                OutRow = OutRow + 1
                OutputLoc.Offset(OutRow, 0) = po
                OutputLoc.Offset(OutRow, 1) = style
                OutputLoc.Offset(OutRow, 2) = InputLoc.Offset(InRow, 0)
                co = 2
                If sizes Is Nothing Then
                    For ci = 2 To 30
                        If InputLoc.Offset(InRow, ci) <> "" Then
                            co = co + 1
                            OutputLoc.Offset(OutRow, co) = CStr(InputLoc.Offset(InRow, ci))
                        End If
                    Next ci
                    OutputLoc.Offset(OutRow, 0).Resize(, 9).Interior.Color = vbRed
                Else
                    For Each x In Array("XS", "S", "M", "L", "XL", "XXL")
                        co = co + 1
                        If sizes.exists(x) Then
                            OutputLoc.Offset(OutRow, co) = InputLoc.Offset(InRow, sizes(x))
                        End If
                    Next x
                End If
            End If
        End If
        InRow = InRow + 1
    Wend
        
End Sub

On the first 2 indented lines, change the InputLoc and OutputLoc to point to the top left corner of the ranges. Press F5 to run it. Go back to Excel and see how it worked. Given the sample sheet you had, I added an XS column. Also, just below the last PO number listed, there is no "Color" line with the sizes, or a Style line, so I highlighted it for manual evaluation. Let me know how this works.
 
Upvote 0
Many thanks, Eric. It worked for me. However, It still have two questions below. Please help clarify me.

1. I found that my other PO contains one more size is 3XL. I will need to add "3XL" into array on VBA code right?
2. In special cases that you highlighted in red for manual evaluation. Of course, I can correct it manually for these special cases.
But I wonder if you can modify VBA code to automatically correct these special cases.

Here below are two special cases. The reason for these is that sometimes, style row and "color, sizes" title row sit on previous page while color name and quantity is located on next page as example 1
OR style row, "color, sizes" title row and somes colorways sit on previous page while balance colorways is located on next page as example 2.
Please help check if you can :)

Example 1:
1742528686135.png


Example 2:
1742528956177.png
 
Upvote 0
I resend you my extend original PO. Please kindly note on original, it's "P.O. NUMB" not "P.O. NUMBER"
Thanks,


P.O. NUMB38154
MF25XK77B
Color S M L XL XXL
LUNAR 7 25 36 24 8
OSGRY 20 70 98 66 21
SHW 15 51 71 48 15
P.O. NUMB38155
MF25XK77B
Color S M L XL XXL
LUNAR 18 112 161 106 28
OSGRY 11 66 95 62 16
SHW 15 85 123 80 22
P.O. NUMB38177
LF25EB18
Color XS S M L XL
MSPCE 8 20 21 10 4
WHT 10 24 25 12 4
MF25EK45
Color S M L XL XXL 3XL
BLHZE 72 255 350 220 78 25
NPINE 43 153 210 132 47 15
SKY 63 214 301 191 71 10
MF25EK45A
Color S M L XL XXL 3XL
ETIDE 18 64 87 55 20 6
MF25EK45B
Color S M L XL XXL 3XL
ETIDE 43 153 210 132 47 15
NAV 36 128 174 110 39 13
MF25EK45C
Color S M L XL XXL 3XL
SNV 29 102 140 88 31 10
P.O. NUMB38177
MF25EK50S
Color S M L XL XXL 3XL
ETIDE 34 122 158 95 32 9
SEAPT 19 68 86 53 18 6
MF25EK51S
Color S M L XL XXL 3XL
SEAPT 10 37 49 29 10 3
TNGO 9 34 41 26 9 6
MF25EK52S
Color S M L XL XXL 3XL
ETIDE 11 39 51 32 11 6
MF25EK54S
Color S M L XL XXL 3XL
WHT 9 29 37 24 8 6
MF25EK55S
Color S M L XL XXL 3XL
SEAPT 13 47 62 37 13 3
MF25EK56S
Color S M L XL XXL 3XL
P.O. NUMB38177
ETIDE 14 50 64 40 14 6
SEAPT 18 64 84 50 17 5
MF25XK01E
Color S M L XL XXL
BLUTZ 22 77 99 59 18
MF25XK02E
Color S M L XL XXL
DOG 41 130 155 86 31
MF25XK04E
Color S M L XL XXL
BLUTZ 14 49 63 38 11
MF25XK06E
Color S M L XL XXL
MROSE 55 176 212 120 42
MF25XK07E
Color S M L XL XXL
DOG 38 120 142 79 29
P.O. NUMB38177
MF25XK08K
Color S M L XL XXL
LUNAR 20 70 90 54 16
MF25XK11E
Color S M L XL XXL
BLUTZ 45 154 198 119 34
MF25XK12E
Color S M L XL XXL
LUNAR 36 110 129 71 26
MF25XK13E
Color S M L XL XXL
WHT 28 98 126 75 23
MF25XK15E
Color S M L XL XXL
WHT 26 91 117 70 21
MF25XK50E
Color S M L XL XXL
LUNAR 14 49 63 38 11
P.O. NUMB38177
MF25XK51E
Color S M L XL XXL
DOG 31 94 110 60 22
LUNAR 12 42 54 32 10
MF25XK52E
Color S M L XL XXL
W/BFR 50 158 188 106 37
MF25XK60
Color S M L XL XXL
BLUTZ 29 101 143 96 31
DOG 13 44 63 42 13
OAT 93 312 424 275 96
MF25XK61
Color S M L XL XXL
LUNAR 9 32 44 30 10
NAV 19 63 89 60 19
OSGRY 15 51 71 48 15
YF25EK11S
Color XS S M L XL
ETIDE 8 15 21 26 24
P.O. NUMB38177
YF25EK45
Color XS S M L XL
TNGO 7 14 18 23 22
YF25EK45A
Color XS S M L XL
ETIDE 11 21 28 33 33
YF25EK45B
Color XS S M L XL
NAV 10 19 25 30 29
P.O. NUMB38177
P.O. NUMB38178
LF25EB18M
Color XS S M L XL
IVO 6 16 17 8 3
P.O. NUMB38179
LF25EB18M
Color XS S M L XL
IVO 48 112 124 76 17
P.O. NUMB38180
MF25EK11S
Color S M L XL XXL 3XL
BLHZE 30 108 141 84 29 8
ETIDE 10 37 49 29 10 3
MEA 6 17 21 13 6 6
PPRBR 21 74 96 58 20 6
TNGO 6 11 13 8 6 6
MF25EK46
Color S M L XL XXL
BLHZE 11 37 53 36 13
CBLU 5 19 27 18 6
OSGRY 8 28 40 27 10
P.O. NUMB38180
P.O. NUMB38181
MF25EK42
Color S M L XL XXL
ETIDE 59 199 285 188 69
NAV 52 174 249 164 61
NPINE 18 62 89 60 21
MF25EK45A
Color S M L XL XXL 3XL
ETIDE 40 132 186 119 45 3
MF25EK51S
Color S M L XL XXL 3XL
SEAPT 5 19 24 15 5 1
TNGO 5 17 22 13 5 1
MF25EK56S
Color S M L XL XXL 3XL
ETIDE 7 25 33 20 7 2
SEAPT 9 32 42 25 9 2
MF25XK01E
Color S M L XL XXL
BFRST 57 177 208 116 42
BLUTZ 48 146 167 92 35
BRLY 47 142 163 89 34
P.O. NUMB38181
GALE 51 156 181 100 37
NAV 12 42 54 32 10
MF25XK03E
Color S M L XL XXL
ANWAL 9 32 41 24 7
BFRST 65 205 244 137 49
LUNAR 53 163 190 105 39
WHT 19 67 86 51 15
MF25XK12E
Color S M L XL XXL
BFRST 49 149 172 94 36
NAV 9 31 39 24 7
SHW 12 42 54 32 10
MF25XK16E
Color S M L XL XXL
NAV 55 170 199 111 40
SHW 20 70 90 54 16
WIS 53 163 190 105 39
MF25XK51E
Color S M L XL XXL
LUNAR 43 128 145 78 31
P.O. NUMB38181
NAV 48 143 164 89 34
MF25XK52E
Color S M L XL XXL
W/SHW 50 149 172 94 35
MF25XK53E
Color S M L XL XXL
NAV 46 139 159 86 33
MF25XK61
Color S M L XL XXL
OSGRY 31 97 120 71 31
MF25XK65
Color S M L XL XXL
LUNAR 11 38 53 36 12
NAV 13 44 63 42 13
P.O. NUMB38181
P.O. NUMB38182
MF25EK45
Color S M L XL XXL 3XL
BLHZE 36 128 174 110 39 13
NPINE 21 77 105 66 23 8
SKY 14 51 70 44 16 5
 
Upvote 0
OK, try this:

VBA Code: 
Sub ReOrg()
Dim InputLoc As Range, OutputLoc As Range
Dim lr As Long, InRow As Long, OutRow As Long
Dim po As String, style As String, sizes As Object
Dim c As Long, ci As Long, co As Long, work As Long, x As Variant


    Set InputLoc = Sheets("Sheet1").Range("A1")
    Set OutputLoc = Sheets("Sheet2").Range("A1")
    
    Application.ScreenUpdating = False
    lr = InputLoc.End(xlDown).Row
    OutputLoc.Resize(lr * 2, 10).ClearContents
    OutputLoc.Resize(lr * 2, 10).Interior.Color = xlNone
    
    OutputLoc.Resize(, 10) = Array("P.O.", "Style", "Color", "XS", "S", "M", "L", "XL", "XXL", "3XL")
    InRow = 0
    OutRow = 0
    
    While InputLoc.Offset(InRow, 0) <> ""
        If Left(InputLoc.Offset(InRow, 0), 4) = "P.O." Then
            If InputLoc.Offset(InRow, 1) <> po Then
                po = InputLoc.Offset(InRow, 1)
                style = ""
                Set sizes = Nothing
            End If
        End If
        
        If InputLoc.Offset(InRow, 0) = "Color" Then
            Set sizes = CreateObject("Scripting.Dictionary")
            For c = 2 To 30
                If InputLoc.Offset(InRow, c) <> "" Then
                    sizes(CStr(InputLoc.Offset(InRow, c))) = c
                End If
            Next c
        End If
        
        work = WorksheetFunction.CountA(InputLoc.Offset(InRow, 2).Resize(, 30))
        If work = 0 Then
            If Left(InputLoc.Offset(InRow, 0), 4) <> "P.O." Then style = InputLoc.Offset(InRow, 0)
        Else
            If InputLoc.Offset(InRow, 0) <> "Color" Then
                OutRow = OutRow + 1
                OutputLoc.Offset(OutRow, 0) = po
                OutputLoc.Offset(OutRow, 1) = style
                OutputLoc.Offset(OutRow, 2) = InputLoc.Offset(InRow, 0)
                co = 2
                If sizes Is Nothing Then
                    For ci = 2 To 30
                        If InputLoc.Offset(InRow, ci) <> "" Then
                            co = co + 1
                            OutputLoc.Offset(OutRow, co) = CStr(InputLoc.Offset(InRow, ci))
                        End If
                    Next ci
                    OutputLoc.Offset(OutRow, 0).Resize(, 10).Interior.Color = vbRed
                Else
                    For Each x In Array("XS", "S", "M", "L", "XL", "XXL", "3XL")
                        co = co + 1
                        If sizes.exists(x) Then
                            ci = InputLoc.Offset(InRow, sizes(x))
                            For ci = sizes(x) - 1 To sizes(x) + 1
                                If InputLoc.Offset(InRow, ci) <> "" Then
                                    OutputLoc.Offset(OutRow, co) = InputLoc.Offset(InRow, ci)
                                    If ci <> sizes(x) Then OutputLoc.Offset(OutRow, 0).Resize(, 10).Interior.Color = vbCyan
                                End If
                            Next ci
                        End If
                    Next x
                End If
            End If
        End If
        InRow = InRow + 1
    Wend
        
    Application.ScreenUpdating = True
End Sub

1) I added the 3XL column.
2) For the P.O. lines, I just check to see if the left 4 characters are "P.O.", so it will for for either "P.O. NUMB" or "P.O. NUMBER".
3) If I come across a new P.O. line, I will not clear out the style or the size headings IF the P.O. number is the same as what is currently being processed.
4) Trying to fix the size values is somewhat problematic in these cases, since the values are not in the same column as the headings, they are offset by 1. So I check the column with the heading, plus the column before and after. If I find a value, I'll use it. But I can't be absolutely sure that this is correct always, so I flagged it with a blue shade. If there is no current size heading at all, I'll still flag it in red. If you don't like that, look for the lines that end with vbRed and vbCyan and delete those lines, or just change those key words to xlNone.
5) I added the Application.ScreenUpdating lines to hopefully speed it up some.

Hope this helps, I tried it on your latest data, and it looked good to me.
 
Upvote 0
Hi Eric
Sorry. I just found I have one more size XXS. So sorry.
And I tried your latest VBA code. There are still some missing on special cases as below.
Please help check if you can address these issues.
If not, I'm almost satisfied with your latest VBA code and will manually correct missings on highlight rows :)

1: Results missing some quantity at far right.
1742541263403.png


2: Results missing quantity at far right and quantity sizes should be S to XXL instead of M to XXL
1742541283378.png
 
Upvote 0
Try this:

VBA Code: 
Sub ReOrg()
Dim InputLoc As Range, OutputLoc As Range
Dim lr As Long, InRow As Long, OutRow As Long, NumCols As Long
Dim po As String, style As String, sizes As Object
Dim c As Long, ci As Long, co As Long, work As Long, x As Variant


    Set InputLoc = Sheets("Sheet10").Range("A1")            ' set input location
    Set OutputLoc = Sheets("Sheet11").Range("A1")           ' set output location
    NumCols = 3                                             ' Number of columns to the right to search
   
    Application.ScreenUpdating = False                      ' Disable screenupdating for speed
    lr = InputLoc.End(xlDown).Row                           ' find last row of input data
    OutputLoc.Resize(lr * 2, 11).ClearContents              ' clear contents of output area
    OutputLoc.Resize(lr * 2, 11).Interior.Color = xlNone    ' clear colors of output area
   
    OutputLoc.Resize(, 11) = Array("P.O.", "Style", "Color", "XXS", "XS", "S", "M", "L", "XL", "XXL", "3XL")
    InRow = 0                                               ' Starting row of input
    OutRow = 0                                              ' Starting row of output
   
    While InputLoc.Offset(InRow, 0) <> ""                   ' check each row of input
   
        If Left(InputLoc.Offset(InRow, 0), 4) = "P.O." Then ' Is it a PO line?
            If InputLoc.Offset(InRow, 1) <> po Then         ' Does this line match the current PO being processed?
                po = InputLoc.Offset(InRow, 1)              ' If not, reset the current settings
                style = ""                                  ' clear the style
                Set sizes = Nothing                         ' clear the color headings
            End If
        End If
       
        If InputLoc.Offset(InRow, 0) = "Color" Then         ' Is this a "color" row?
            Set sizes = CreateObject("Scripting.Dictionary")    ' If yes, we want to save the sizes,
            For c = 2 To 40                                     ' and the columns where the sizes are
                If InputLoc.Offset(InRow, c) <> "" Then         ' found an empty column?
                    sizes(CStr(InputLoc.Offset(InRow, c))) = c  ' save the size and column offset
                End If
            Next c
        End If
       
        work = WorksheetFunction.CountA(InputLoc.Offset(InRow, 2).Resize(, 30))     ' Count non-empty cells
        If work = 0 Then                                                            ' nothing after column 2?
            If Left(InputLoc.Offset(InRow, 0), 4) <> "P.O." Then style = InputLoc.Offset(InRow, 0)  ' must be a style
        Else                                                                        ' has something?
            If InputLoc.Offset(InRow, 0) <> "Color" Then                            ' and it's not a "color" row?
                OutRow = OutRow + 1                                                 ' must be a data row
                OutputLoc.Offset(OutRow, 0) = po                                    ' create a new output row
                OutputLoc.Offset(OutRow, 1) = style                                 ' with po, style and color
                OutputLoc.Offset(OutRow, 2) = InputLoc.Offset(InRow, 0)
                co = 2
                If sizes Is Nothing Then                                            ' no active color headings?
                    For ci = 2 To 30
                        If InputLoc.Offset(InRow, ci) <> "" Then                    ' just put the data in the
                            co = co + 1                                             ' first cells available
                            OutputLoc.Offset(OutRow, co) = CStr(InputLoc.Offset(InRow, ci))
                        End If
                    Next ci
                    OutputLoc.Offset(OutRow, 0).Resize(, 10).Interior.Color = vbRed ' and mark the row in red
                Else
                    For Each x In Array("XXS", "XS", "S", "M", "L", "XL", "XXL", "3XL")
                        co = co + 1                                                 ' increment the output column
                        If sizes.exists(x) Then                                     ' do we have this size?
                            ci = InputLoc.Offset(InRow, sizes(x))                   ' find the original column
                            For ci = sizes(x) To sizes(x) + NumCols                 ' check 4 columns
                                If InputLoc.Offset(InRow, ci) <> "" Then            ' found an empty cell?
                                    OutputLoc.Offset(OutRow, co) = InputLoc.Offset(InRow, ci)   ' save it
                                                                                    ' if not the original column, color it blue
                                    If ci <> sizes(x) Then OutputLoc.Offset(OutRow, 0).Resize(, 10).Interior.Color = vbCyan
                                    Exit For
                                End If
                            Next ci
                                                                                    ' Nothing output?  Flag the row
                            If OutputLoc.Offset(OutRow, co) = "" Then OutputLoc.Offset(OutRow, 0).Resize(, 10).Interior.Color = vbCyan
                        End If
                    Next x
                End If
            End If
        End If
        InRow = InRow + 1               ' check the next input row
    Wend
       
    Application.ScreenUpdating = True   ' restore screen updating
End Sub

1) I added the XXS column.
2) As far as the special cases, those were not found since the first was offset from the column heading by 2, and the second was offset from the column heading by 3. The previous iteration of my macro only looked 1. Based on what I saw from your examples, if the values are offset, they will always be to the right. Probably some quirk of reading the PDF. So I changed the macro to only look to the right, and for a maximum of 3 columns. I would NOT recommend going more than 3, since that could put you into the next size. But you can change it if you want. The third indented line is now:

VBA Code: 
    NumCols = 3

You can change that if you want. Even reduce it if it causes problems.

In any event, this is my last version of the macro. It doesn't make sense to keep trying to fix smaller and smaller issues, that I can't see in the sample data I've been given. It works for most of the cases, and flags the rest for manual review. That's probably as good as we can expect. I added comments to assist in case anyone else wants to take a look at it.

Good luck!
 
Upvote 0
Solution
Hi Eric, I tried and it worked perfectly now for all my POs :)
Really appreciate your helps. Thanks to you, I was able to get my work done efficiently.
I also want to apologize for repeatedly asking you to make small changes instead of providing all the necessary information from the beginning.
Thank you for your patience and for sticking with me through it all.

Wishing you a great day and weekend!
 
Upvote 0
You must log in or register to reply here.

Similar threads

D
  • Question Question
Data Copy and Transpose
Replies
3
Views
279
decent_boy
D
K
  • Question Question
conditional formatting question
Replies
2
Views
732
kerm007
K
M
  • Question Question
Formulas with Inititals with Last Name
Replies
3
Views
202
Fluff
Fluff
S
  • Question Question
Excel VBA to create multi rows based on column header
Replies
1
Views
533
bebo021999
B
F
  • Question Question
Custom search bar - Creating a front end for My Sold Research Tool.
Replies
0
Views
304
frewert
F

Share this page

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