consolidate rows into single row

BKHELP · Sep 8th 2015

Hi,

I am fairly new to VBA so please go easy on me. I am looking for a code that will consolidate mutiple rows on data into a single row, then delete the unneeded lines. The data is not always in order so I am thinking I would first need to sort the data, but hoping this can be included in the code. In addition, there may be duplicates in the 1st two columns within the raw data, and it would always be the case that the 1st "TIME IN" corresponds to the 1st "TIME OUT".

The raw data is being copied/pasted from another workbook, via another macro at a specific time of day, so ideally this would run after that macro (ideally 5:00AM).

[TABLE="width: 267"]

[tr]

[TD="class: xl66, width: 56, bgcolor: #4F81BD"]MO #[/TD]
[TD="class: xl66, width: 71, bgcolor: #4F81BD"]LOCATION[/TD]
[TD="class: xl67, width: 114, bgcolor: #4F81BD"]TIME IN[/TD]
[TD="class: xl67, width: 114, bgcolor: #4F81BD"]TIME OUT[/TD]

[/tr]

[tr]

[TD="class: xl68, bgcolor: transparent, align: right"]1234567[/TD]
[TD="class: xl68, bgcolor: transparent"]STOCK[/TD]
[TD="class: xl69, bgcolor: transparent, align: right"]9/5/15 2:26 PM[/TD]
[TD="class: xl69, bgcolor: transparent"] [/TD]

[/tr]

[tr]

[TD="class: xl68, bgcolor: transparent, align: right"]5555555[/TD]
[TD="class: xl68, bgcolor: transparent"]CNC[/TD]
[TD="class: xl69, bgcolor: transparent, align: right"]8/29/15 12:00 AM[/TD]
[TD="class: xl69, bgcolor: transparent"] [/TD]

[/tr]

[tr]

[TD="class: xl68, bgcolor: transparent, align: right"]2345678[/TD]
[TD="class: xl68, bgcolor: transparent"]PAINT[/TD]
[TD="class: xl69, bgcolor: transparent, align: right"]9/5/15 2:27 PM[/TD]
[TD="class: xl69, bgcolor: transparent"] [/TD]

[/tr]

[tr]

[TD="class: xl68, bgcolor: transparent, align: right"]5555555[/TD]
[TD="class: xl68, bgcolor: transparent"]CNC[/TD]
[TD="class: xl69, bgcolor: transparent"] [/TD]
[TD="class: xl69, bgcolor: transparent, align: right"]9/5/15 12:00 AM[/TD]

[/tr]

[tr]

[TD="class: xl68, bgcolor: transparent, align: right"]1234567[/TD]
[TD="class: xl68, bgcolor: transparent"]STOCK[/TD]
[TD="class: xl69, bgcolor: transparent, align: right"]9/5/15 2:47 PM[/TD]
[TD="class: xl69, bgcolor: transparent"] [/TD]

[/tr]

[tr]

[TD="class: xl68, bgcolor: transparent, align: right"]1234567[/TD]
[TD="class: xl68, bgcolor: transparent"]STOCK[/TD]
[TD="class: xl69, bgcolor: transparent"] [/TD]
[TD="class: xl69, bgcolor: transparent, align: right"]9/9/15 12:00 AM[/TD]

[/tr]

[tr]

[TD="class: xl68, bgcolor: transparent, align: right"]3456789[/TD]
[TD="class: xl68, bgcolor: transparent"]OFFICE[/TD]
[TD="class: xl69, bgcolor: transparent, align: right"]9/7/15 12:00 AM[/TD]
[TD="class: xl69, bgcolor: transparent"] [/TD]

[/tr]

[tr]

[TD="class: xl68, bgcolor: transparent, align: right"]1234567[/TD]
[TD="class: xl68, bgcolor: transparent"]STOCK[/TD]
[TD="class: xl69, bgcolor: transparent"] [/TD]
[TD="class: xl69, bgcolor: transparent, align: right"]9/10/15 12:00 AM[/TD]

[/tr]

[tr]

[TD="class: xl68, bgcolor: transparent, align: right"]2345678[/TD]
[TD="class: xl68, bgcolor: transparent"]PAINT[/TD]
[TD="class: xl69, bgcolor: transparent"] [/TD]
[TD="class: xl69, bgcolor: transparent, align: right"]9/6/15 12:00 AM[/TD]

[/tr]

[/TABLE]

Once the code runs, I would like the data to look like this.

[TABLE="width: 267"]

[tr]

[TD="class: xl65, width: 56, bgcolor: #4F81BD"]MO #[/TD]
[TD="class: xl65, width: 71, bgcolor: #4F81BD"]LOCATION[/TD]
[TD="class: xl66, width: 114, bgcolor: #4F81BD"]TIME IN[/TD]
[TD="class: xl66, width: 114, bgcolor: #4F81BD"]TIME OUT[/TD]

[/tr]

[tr]

[TD="class: xl67, bgcolor: transparent, align: right"]1234567[/TD]
[TD="class: xl67, bgcolor: transparent"]STOCK[/TD]
[TD="class: xl68, bgcolor: transparent, align: right"]9/5/15 2:26 PM[/TD]
[TD="class: xl68, bgcolor: transparent, align: right"]9/9/15 12:00 AM[/TD]

[/tr]

[tr]

[TD="class: xl67, bgcolor: transparent, align: right"]1234567[/TD]
[TD="class: xl67, bgcolor: transparent"]STOCK[/TD]
[TD="class: xl68, bgcolor: transparent, align: right"]9/5/15 2:47 PM[/TD]
[TD="class: xl68, bgcolor: transparent, align: right"]9/10/15 12:00 AM[/TD]

[/tr]

[tr]

[TD="class: xl67, bgcolor: transparent, align: right"]2345678[/TD]
[TD="class: xl67, bgcolor: transparent"]PAINT[/TD]
[TD="class: xl68, bgcolor: transparent, align: right"]9/5/15 2:27 PM[/TD]
[TD="class: xl68, bgcolor: transparent, align: right"]9/6/15 12:00 AM[/TD]

[/tr]

[tr]

[TD="class: xl67, bgcolor: transparent, align: right"]3456789[/TD]
[TD="class: xl67, bgcolor: transparent"]OFFICE[/TD]
[TD="class: xl68, bgcolor: transparent, align: right"]9/7/15 12:00 AM[/TD]
[TD="class: xl68, bgcolor: transparent"] [/TD]

[/tr]

[tr]

[TD="class: xl67, bgcolor: transparent, align: right"]5555555[/TD]
[TD="class: xl67, bgcolor: transparent"]CNC[/TD]
[TD="class: xl68, bgcolor: transparent, align: right"]8/29/15 12:00 AM[/TD]
[TD="class: xl68, bgcolor: transparent, align: right"]9/5/15 12:00 AM[/TD]

[/tr]

[/TABLE]

Appreciate any help on the code for this.

cytop · Sep 8th 2015

Re: consolidate rows into single row

Can it be assumed that the 'IN' row will always appear before the 'OUT' row? ~~and that there will only be 1 matching pair of MO/Location~~ Scratch that but can assume that an 'IN' will match with the next 'OUT' for that MO/Location

And how many rows are involved? Couple of hundred, couple of thousand? 10s of thousands?? Only asking as there's an easy, but inefficient, way of doing this that can handle a thousand or so rows fairly quickly.

BKHELP · Sep 8th 2015

Re: consolidate rows into single row

HI there,

Can it be assumed that the 'IN' row will always appear before the 'OUT' row? and that there will only be 1 matching pair of MO/Location Scratch that but can assume that an 'IN' will match with the next 'OUT' for that MO/Location - yes 'IN' will always appear before 'OUT', and yes 'IN' will always match the next 'OUT'

And how many rows are involved? Couple of hundred, couple of thousand? 10s of thousands?? Only asking as there's an easy, but inefficient, way of doing this that can handle a thousand or so rows fairly quickly. - will be anywhere from 5000 to 10,000 rows

Thank you for your help!!!

cytop · Sep 8th 2015

Re: consolidate rows into single row

Ok - too many rows for what I was thinking. perhaps someone else will pop in as it's getting late here.

BKHELP · Sep 8th 2015

Re: consolidate rows into single row

ok, well apprecaite your help, if you think of anything, please let me know.

jindon · Sep 9th 2015

Re: consolidate rows into single row

Assuming Herader from A1

Code

Sub test()
    Dim a, i As Long, ii As Long, w, n As Long
    With Cells(1).CurrentRegion
        a = .Value: ReDim w(1 To UBound(a, 2))
        With CreateObject("Scripting.Dictionary")
            For i = 2 To UBound(a, 1)
                If a(i, 3) <> "" Then
                    If Not .exists(a(i, 1)) Then
                        ReDim w(1 To UBound(a, 2), 1 To 1)
                    Else
                        w = .Item(a(i, 1))
                        ReDim Preserve w(1 To UBound(a, 2), 1 To UBound(w, 2) + 1)
                    End If
                    For ii = 1 To UBound(a, 2)
                        w(ii, UBound(w, 2)) = a(i, ii)
                    Next
                    .Item(a(i, 1)) = w
                ElseIf a(i, 4) <> "" Then
                    w = .Item(a(i, 1))
                    For ii = 1 To UBound(w, 2)
                        If w(4, ii) = "" Then w(4, ii) = a(i, 4): Exit For
                    Next
                    .Item(a(i, 1)) = w
                End If
            Next
            w = .items
        End With
        With .Offset(, .Columns.Count + 1)
            .Rows(1).Value = a: n = 2
            For i = 0 To UBound(w)
                .Rows(n).Resize(UBound(w(i), 2)).Value = Application.Transpose(w(i))
                n = n + UBound(w(i), 2)
            Next
            With .Resize(n)
                .Sort .Cells(1), 1, , , , , , 1
            End With
        End With
    End With
End Sub

Display More

BKHELP · Sep 9th 2015

Re: consolidate rows into single row

thank you, when I copy the code, I am receiving an error message - run time error '13, type mismatch, on For ii = 1 To UBound(w, 2)?

jindon · Sep 9th 2015

Re: consolidate rows into single row

Then I need to see your workbook, not a picture.

BKHELP · Sep 9th 2015

Re: consolidate rows into single row

I have attached the file. Thank you!

jindon · Sep 9th 2015

Re: consolidate rows into single row

You have Comments in col.C
Strongly recommend not use procedure name like "sort".
It's a VBA reserved word.

Code

Sub test()
    Dim a, i As Long, ii As Long, w, n As Long
    With Cells(1).CurrentRegion
        a = .Value: ReDim w(1 To UBound(a, 2))
        With CreateObject("Scripting.Dictionary")
            For i = 2 To UBound(a, 1)
                If a(i, 4) <> "" Then
                    If Not .exists(a(i, 1)) Then
                        ReDim w(1 To UBound(a, 2), 1 To 1)
                    Else
                        w = .Item(a(i, 1))
                        ReDim Preserve w(1 To UBound(a, 2), 1 To UBound(w, 2) + 1)
                    End If
                    For ii = 1 To UBound(a, 2)
                        w(ii, UBound(w, 2)) = a(i, ii)
                    Next
                    .Item(a(i, 1)) = w
                ElseIf a(i, 5) <> "" Then
                    w = .Item(a(i, 1))
                    For ii = 1 To UBound(w, 2)
                        If w(5, ii) = "" Then w(5, ii) = a(i, 5): Exit For
                    Next
                    .Item(a(i, 1)) = w
                End If
            Next
            w = .items
        End With
        With .Offset(, .Columns.Count + 1)
            .Rows(1).Value = a: n = 2
            For i = 0 To UBound(w)
                .Rows(n).Resize(UBound(w(i), 2)).Value = Application.Transpose(w(i))
                n = n + UBound(w(i), 2)
            Next
            With .Resize(n)
                .Sort .Cells(1), 1, , , , , , 1
            End With
        End With
    End With
End Sub

Display More

BKHELP · Sep 9th 2015

Re: consolidate rows into single row

this works great!! Thank you and thank you for the advise, I will change the "sort" to something more defined.

BKHELP · Oct 5th 2015

Re: consolidate rows into single row

[ATTACH=CONFIG]67118[/ATTACH]

Jindon,

The file was working wonderful until this morning, when I received a runtime error message type mismatch (on this line of the code SHOWN BELOW), nothing on the files has changed except added more worksheets and more columns to the same sheet but under seperate columns. The raw data seems to copy and paste fine but when it goes to format i receive the error.

Code

For ii = 1 To UBound(w, 2)

The file is too large to attach, but a picture of the column headings is attached in case you need it.
COLUMN A-E CONTAIN THE RAW DATA COPIED FROM ANOTHER WORKBOOK
COLUMN F IS BLANK
COLUMN G-K SHOULD BE FORMATTED DATA PULLED FROM A-E
COLUMN L-R ADDITIONAL DATA USING FORMATTED DATA IN G-K

Appreciate any help!

Thanks,
Beth

jindon · Oct 6th 2015

Re: consolidate rows into single row

1) I need to see your file anyway. (You could upload some free storage like filedropper...)

2) Which one of that line?

BKHELP · Oct 6th 2015

Re: consolidate rows into single row

Jindon, Thanks great idea, here is the link
http://www.filedropper.com/locationmo

BKHELP · Oct 6th 2015

Re: consolidate rows into single row

sorry, here is the correct link
<a href=http://www.filedropper.com/locationmo><img src=http://www.filedropper.com/download_button.png width=127 height=145 border=0/></a><br /><div style=font-size:9px;font-family:Arial, Helvetica, sans-serif;width:127px;font-color:#44a854;> <a href=http://www.filedropper.com >file storage online</a></div>

jindon · Oct 6th 2015

Re: consolidate rows into single row

Change to

Code

Sub MOformat()
    Dim a, i As Long, ii As Long, w, n As Long
    With Cells(1).CurrentRegion
        a = .Value: ReDim w(1 To UBound(a, 2))
        mySort a, 2, UBound(a, 1), 4, 0
        With CreateObject("Scripting.Dictionary")
            For i = 2 To UBound(a, 1)
                If a(i, 4) <> "" Then
                    If Not .exists(a(i, 1)) Then
                        ReDim w(1 To UBound(a, 2), 1 To 1)
                    Else
                        w = .Item(a(i, 1))
                        ReDim Preserve w(1 To UBound(a, 2), 1 To UBound(w, 2) + 1)
                    End If
                    For ii = 1 To UBound(a, 2)
                        w(ii, UBound(w, 2)) = a(i, ii)
                    Next
                    .Item(a(i, 1)) = w
                ElseIf a(i, 5) <> "" Then
                    If .exists(a(i, 1)) Then
                        w = .Item(a(i, 1))
                        For ii = 1 To UBound(w, 2)
                            If w(5, ii) = "" Then w(5, ii) = a(i, 5): Exit For
                        Next
                        .Item(a(i, 1)) = w
                    End If
                End If
            Next
            w = .items
        End With
        With .Offset(, .Columns.Count + 1)
            .Rows(1).Value = a: n = 2
            For i = 0 To UBound(w)
                .Rows(n).Resize(UBound(w(i), 2)).Value = Application.Transpose(w(i))
                n = n + UBound(w(i), 2)
            Next
            With .Resize(n)
                .Sort .Cells(1), 1, , , , , , 1
            End With
        End With
    End With
End Sub




Private Sub mySort(a, LB As Long, UB As Long, ref As Long, myOrd As Boolean)
    Dim i As Long, ii As Long, iii As Long, temp, x, y
    For i = LB To UB - 1
        For ii = UB To i + 1 Step -1
            x = a(i, ref): y = a(ii, ref)
            If (Not IsNumeric(x)) + (IsEmpty(x)) Then x = Chr(34) & x & Chr(34)
            If Not IsNumeric(y) + (IsEmpty(y)) Then y = Chr(34) & y & Chr(34)
            If Evaluate(x & IIf(myOrd, ">", "<") & y) Then
                For iii = 1 To UBound(a, 2)
                    temp = a(i, iii): a(i, iii) = a(ii, iii)
                    a(ii, iii) = temp
                Next
            End If
        Next
    Next
End Sub

Display More

BKHELP · Oct 6th 2015

Re: consolidate rows into single row

jindon,
thank you!!! it works! greatful for your help!

BKHELP · Oct 13th 2015

Re: consolidate rows into single row

Jindon,

You have been so helpful, the file is timing put before it finishes running, can you take a look and see if there is something that I can do to speed it up. It seems to lock up when it goes to run the macro MOFormat

http://www.filedropper.com/locationmo

<a href=http://www.filedropper.com/locationmo><img src=http://www.filedropper.com/download_button.png width=127 height=145 border=0/></a><br /><div style=font-size:9px;font-family:Arial, Helvetica, sans-serif;width:127px;font-color:#44a854;> <a href=http://www.filedropper.com >file upload</a></div>

Thanks, Beth

jindon · Oct 13th 2015

Re: consolidate rows into single row

What is the reason to place blank row in row 1?
It's not a good practice and also a bad procedure name "sort"....

Code

Sub MOformat()
'combines in and out times onto single row for format and reporting
    
    Dim a, i As Long, ii As Long, w, n As Long
    With Cells(1).CurrentRegion
        a = .Value: ReDim w(1 To UBound(a, 2))
        mySort a, 3, UBound(a, 1), 4, 0
        With CreateObject("Scripting.Dictionary")
            For i = 3 To UBound(a, 1)
                If a(i, 4) <> "" Then
                    If Not .exists(a(i, 1)) Then
                        ReDim w(1 To UBound(a, 2), 1 To 1)
                    Else
                        w = .Item(a(i, 1))
                        ReDim Preserve w(1 To UBound(a, 2), 1 To UBound(w, 2) + 1)
                    End If
                    For ii = 1 To UBound(a, 2)
                        w(ii, UBound(w, 2)) = a(i, ii)
                    Next
                    .Item(a(i, 1)) = w
                ElseIf a(i, 5) <> "" Then
                    If .exists(a(i, 1)) Then
                        w = .Item(a(i, 1))
                        For ii = 1 To UBound(w, 2)
                            If w(5, ii) = "" Then w(5, ii) = a(i, 5): Exit For
                        Next
                        .Item(a(i, 1)) = w
                    End If
                End If
            Next
            w = .items
        End With
        With .Offset(, .Columns.Count + 1)
            .Rows(1).Value = a: n = 3
            For i = 0 To UBound(w)
                .Rows(n).Resize(UBound(w(i), 2)).Value = Application.Transpose(w(i))
                n = n + UBound(w(i), 2)
            Next
            With .Offset(2).Resize(n)
                .sort .Cells(1), 1, , , , , , 1
            End With
        End With
    End With
End Sub

Display More

BKHELP · Oct 16th 2015

Re: consolidate rows into single row

Jinson,

Thank you, no reason for clank row in line 1. I have also changed the procedure to not include "sort" in name. I am receiving an error message. Can you take a look at the file.

http://www.filedropper.com/locationmo_1

<a href=http://www.filedropper.com/locationmo_1><img src=http://www.filedropper.com/download_button.png width=127 height=145 border=0/></a><br /><div style=font-size:9px;font-family:Arial, Helvetica, sans-serif;width:127px;font-color:#44a854;> <a href=http://www.filedropper.com >share files free</a></div>

consolidate rows into single row

Participate now!

Share