How to combine multiple rows making one column into several

0

I have a huge file 15,000+ rows.  The file is created possible with mutiple rows based on each "theme" or "item"

Cust Acct Customer Name Rep Code Location Theme Items 121588     Padron Alex 1  Home Casino Forks 121588     Padron Alex 1  Home Casino Confetti 121588     Padron Alex 1  Home Casino Head gear 116384     Meirs Blake 2  Their Village Casino   111387     Campbell   RJ 11  Our Town Dance Plates 111693     Ford   Steve 12  ABC city Dance Plates 115785     Hastings   David 7  Great Suburb Dance Plates 115837     Taco's RJ 11  Our Town Dance

Plate

I have combined them by hand in the past making each theme  and item its own column

Cust Acct Customer Name Rep Code Location Casion Dance Pool Luau Garden Mystery Confetti Streamers Table cloths Knives Glasses Fork Plate Poppers Table Toppers Games Head Gear 106983     Acme Steve 12  ABC city   y                             y 107765     Botox Steve 12  ABC city                                   111387     Campbell   RJ 11  Our Town   y                     Y         111388     Miller   RJ 11  Our Town   y y     y                     y 111693     Ford   Steve 12  ABC city   y y       y           Y         112412     Smith Blake 2  Their Village   y y     y                       112454     Humphrey's RJ 11  Our Town   y                              

To try and automate it I tried create the columns for themes and items using the following code, but it keeps erroring.  

I have added a sample file below. Any fix to the code or advice on a better way to accmplish my task would be greatly appreciated.

Code_Goes_Here

Code

Sub array_Match_Data()

Dim rSH As Worksheet

Dim sSh As Worksheet

Set rSH = ThisWorkbook.Sheets("RAW DATA")

Set sSh = ThisWorkbook.Sheets("SEARCH DATA")

Dim rawArray() As String

Dim searchArray() As String

'24 at the end is the number of columns in my raw data worksheet

'22 next row is the number of columns in my search data worksheet

ReDim Preserve rawArray(1 To rSH.Range("A" & Rows.Count).End(xlUp).Row, 1 To 24)

ReDim Preserve searchArray(1 To sSh.Range("A" & Rows.Count).End(xlUp).Row, 1 To 22)

For a = 1 To rSH.Range("A" & Rows.Count).End(xlUp).Row

     For b = 1 To 24

          rawArray(a, b) = rSH.Cells(a, b)

     Next b

Next a

For a = 1 To sSh.Range("A" & Rows.Count).End(xlUp).Row

     For b = 1 To 22

          searchArray(a) = sSh.Cells(a)

     Next b

Next a

Dim holdspace As String

Dim stID As Integer

For a = 2 To UBound(searchArray)

     stID = searchArray(a, 1)

     For b = 2 To UBound(rawArray)

          If rawArray(b, 1) = stID Then

If IsEmpty (rawArray(b, 7)) then

     Holdspace = " "

Else

                           searchArray(a, 5) = rawArray(b, 7)

If IsEmpty (rawArray(b, 8)) then

     Holdspace = " "

Else

                           searchArray(a, 6) = rawArray(b, 8)

If IsEmpty (rawArray(b, 9)) then

     Holdspace = " "

Else

                           searchArray(a, 7) = rawArray(b, 9)

If IsEmpty (rawArray(b, 10)) then

     Holdspace = " "

Else

                           searchArray(a, 8) = rawArray(b, 10)

If IsEmpty (rawArray(b, 11)) then

     Holdspace = " "

Else

                           searchArray(a, 9) = rawArray(b, 11)

If IsEmpty (rawArray(b, 12)) then

     Holdspace = " "

Else

                          searchArray(a, 10) = rawArray(b, 12)

If IsEmpty (rawArray(b, 13)) then

     Holdspace = " "

Else

                           searchArray(a, 11) = rawArray(b, 13)

If IsEmpty (rawArray(b, 14)) then

     Holdspace = " "

Else

                           searchArray(a, 12) = rawArray(b, 14)

If IsEmpty (rawArray(b, 15)) then

     Holdspace = " "

Else

                           searchArray(a, 13) = rawArray(b, 15)

If IsEmpty (rawArray(b, 16)) then

     Holdspace = " "

Else

                           searchArray(a, 14) = rawArray(b, 16)

If IsEmpty (rawArray(b, 17)) then

     Holdspace = " "

Else

                           searchArray(a, 15) = rawArray(b, 17)

If IsEmpty (rawArray(b, 18)) then

     Holdspace = " "

Else

                          searchArray(a, 16) = rawArray(b, 18)

If IsEmpty (rawArray(b, 19)) then

     Holdspace = " "

Else

                          searchArray(a, 17) = rawArray(b, 19)

  If IsEmpty (rawArray(b, 20)) then

     Holdspace = " "

Else

                           searchArray(a, 18) = rawArray(b, 20)

If IsEmpty (rawArray(b, 21)) then

     Holdspace = " "

Else

                           searchArray(a, 19) = rawArray(b, 21)

If IsEmpty (rawArray(b, 22)) then

     Holdspace = " "

Else

                           searchArray(a, 20) = rawArray(b, 22)

If IsEmpty (rawArray(b, 23)) then

     Holdspace = " "

Else

                          searchArray(a, 21) = rawArray(b, 23)

If IsEmpty (rawArray(b, 24)) then

     Holdspace = " "

Else

                          searchArray(a, 22) = rawArray(b, 24)

             Exit For

          End If

     Next b

Next a

'Transfer data back

For a = 2 To UBound(searchArray)

     For b = 6 To 22

          sSh.Cells(a, b).Value = searchArray(a, b)

     Next b

Next a

End Sub

Answer
Discuss

Answers

0
Selected Answer

Please take a little time to study the code below. I took some pains to show you a few things that are very simple but you did them in a very complicated way. There are also a few things you didn't try but will find useful to know. On the whole, I think the code does what you intend. Before you run it on your workbook note that your worksheet Raw data as entered has blank spaces at the end of its name. Therefore the code can't recognize it. Remove the blanks from its name.

Option Explicit
Enum Nws                ' worksheet "Input" (Arr) navigation
    ' 068
    NwsFirstDataRow = 2
    NwsAcct = 1         ' name the columns
    NwsName
    NwsRep
    NwsCode
    NwsLoc
    NwsTheme
    NwsItem
End Enum
Sub InputToOutput()
    '068
    
    Dim WsIn            As Worksheet            ' data input
    Dim WsOut           As Worksheet            ' result
    Dim Rng             As Range                ' working range
    Dim Arr             As Variant              ' contents (Value) of a range
    Dim R               As Long                 ' loop counter (row in Input/Arr)
    Dim C               As Long                 ' loop counter (column in Input/Arr)
    Dim Fnd             As Range                ' search result
    Dim Rt              As Long                 ' target row (in Output)
    Dim Ct              As Long                 ' target column (in Output)
    
    Application.ScreenUpdating = False          ' saves time
    Set WsIn = Worksheets("Raw data as entered")
    On Error Resume Next
    Set WsOut = Worksheets("Output")            ' rename to suit
    If Err Then                                 ' error if no such Ws
        ' append a copy of Input at the end
        Worksheets("Input").Copy After:=Worksheets(Worksheets.Count)
        Set WsOut = ActiveSheet
        With WsOut
            .Name = "Output"
            Set Rng = .Range(.Cells(1, 1), .Cells(1, NwsLoc))
            Arr = Rng.Value                     ' copy captions to Arr
            ' retain only some captions and column formatting
            .Cells.ClearContents
            Rng.Value = Arr                     ' return Arr to first row
        End With
    End If
    On Error GoTo 0
    With WsIn
        ' read all data into array Arr
        Arr = .Range(.Cells(NwsFirstDataRow, "A"), .Cells(.Rows.Count, "A").End(xlUp)) _
                     .Resize(, .Cells(1, .Columns.Count).End(xlToLeft).Column).Value
    End With
    
    With WsOut
        For R = 1 To UBound(Arr)
            Rt = Application.Max(.Cells(.Rows.Count, NwsAcct).End(xlUp).Row, _
                                  NwsFirstDataRow)
            ' look at all existing account numbers
            Set Rng = .Range(.Cells(NwsFirstDataRow, NwsAcct), _
                             .Cells(Rt, NwsAcct))
            ' find the account number
            Set Fnd = Rng.Find(What:=Trim(Arr(R, NwsAcct)), _
                               LookIn:=xlValues, LookAt:=xlWhole, _
                               SearchOrder:=xlByRows, SearchDirection:=xlNext)
            If Fnd Is Nothing Then
                ' set up a new row
                Rt = .Cells(.Rows.Count, NwsAcct).End(xlUp).Row + 1
                For C = NwsAcct To NwsLoc
                    .Cells(Rt, C).Value = Arr(R, C)
                Next C
            Else
                Rt = Fnd.Row                    ' target row
            End If
            
            For C = NwsTheme To NwsItem
                If Len(Trim(Arr(R, C))) Then    ' skip if blank
                    Ct = .Cells(1, .Columns.Count).End(xlToLeft).Column
                    Set Rng = .Range(.Cells(1, NwsTheme), .Cells(1, Ct))
                    ' find the theme or item
                    Set Fnd = Rng.Find(What:=Arr(R, C), _
                                       LookIn:=xlValues, LookAt:=xlWhole, _
                                       SearchOrder:=xlByColumns, _
                                       SearchDirection:=xlNext)
                    If Fnd Is Nothing Then
                        ' set up a new theme or item
                        .Columns(Ct).Copy .Columns(Ct + 1)
                        Ct = Ct + 1
                        .Columns(Ct).ClearContents
                        .Cells(1, Ct).Value = Arr(R, C)
                        .Columns(Ct).AutoFit
                    Else
                        Ct = Fnd.Column
                    End If
                    
                    .Cells(Rt, Ct).Value = "Y"
                End If
            Next C
        Next R
    End With
    
    Application.ScreenUpdating = True           ' update the screen now
End Sub

The code looks for a worksheet called Output. If it doesn't exist it's created, taking captions and column formats from the sheet "Raw data as entered". This means that you can run the code on the same Output sheet several times. There is no advantage in doing so because the code will run through all 15K lines anyway. It only adds to the existing but doesn't delete. That could be a source of errors.

The code first looks for an account number in Output and creates it if it isn't found. Then it looks for Themes and Items, in turn, also creating these columns if they don't exist. Finally it writes "Y"s in the appropriate columns.

The best way to use the code should be to prepare the Output sheet with the column captions F:?? sorted  the way you want. That will force the code to use existing columns. If it still adds columns during its run the reason is misspelling either in the setup or in the data capture.

BTW the code reads the account numbers as numbers and finds them as numbers. In your raw data the are followed by a lot of blanks. Blanks are a sure source of problems. Please don't believe that they don't exist because you don't see them. The only thing you don't see is why your code doesn't work lol:  Whatever effect you wish to achieve by their use, achieve it with cell formatting instead.

Discuss

Discussion

Wow, you are awesome!  I have been working on this for weeks, and you fix it in minutes.  Thank you so much, I can't tell you how much this helps.
clcwalker (rep: 4) Jul 15, '20 at 1:49 pm
Add to Discussion


Answer the Question

You must create an account to use the forum. Create an Account or Login