Transpose vertical to horizontal data based on countif?

**dunnobe** · 01-10-2018, 09:36 AM

Hello all,

I would like to transpose some vertical data (timestamps) in worksheet 3 horizontally to worksheet 2.

Steps

1. If you can't find the date from worksheet 2 column A in worksheet 3 column F, nothing should happen.
2. If you can find the date, count the amount of times you find this date and copy the corresponding timestamps (to this date) to worksheet 2.
E.g. 5/07/2017 has 2 timestamps in worksheet 3, thus worksheet 2 should only show a value in column Time1 and Time2.

I don't really know how to loop through this or work with select case or so...

Here below my flawed attempt, but the offset is a bit off and it doesn't copy the right amount of timestamps.

lastRow = ws3.Cells(Rows.Count, "F").End(xlUp).Row
Set r = ws3.Range("F2:F" & lastRow)

i = 2

Do While ws2.Cells(i, 1).Value <> ""

    For x = 1 To Application.WorksheetFunction.CountIf(ws3.Range("F:F"), ws2.Cells(i, 1))

    If r.Find(What:=ws2.Cells(i, 1), LookIn:=xlValues) Is Nothing Then

    ElseIf r.Find(What:=ws2.Cells(i, 1), LookIn:=xlValues) >= 1 Then
    
        ws2.Cells(i, 6).Value = r.Find(What:=ws2.Cells(i, 1), LookIn:=xlValues).Offset(x, 1)
        ws2.Cells(i, 11).Value = r.Find(What:=ws2.Cells(i, 1), LookIn:=xlValues).Offset(x + 1, 1)
        ws2.Cells(i, 16).Value = r.Find(What:=ws2.Cells(i, 1), LookIn:=xlValues).Offset(x + 2, 1)
        ws2.Cells(i, 21).Value = r.Find(What:=ws2.Cells(i, 1), LookIn:=xlValues).Offset(x + 3, 1)
        ws2.Cells(i, 26).Value = r.Find(What:=ws2.Cells(i, 1), LookIn:=xlValues).Offset(x + 4, 1)
        ws2.Cells(i, 31).Value = r.Find(What:=ws2.Cells(i, 1), LookIn:=xlValues).Offset(x + 5, 1)
    
    End If

Next x

i = i + 1

Loop

Expected result:

Capture.JPG

**jindon** · 01-10-2018, 10:19 AM

See if this is how you wanted.

Sub test()
    Dim a, i As Long, ii As Long, dic As Object
    Set dic = CreateObject("Scripting.Dictionary")
    a = Sheets("sheet3").Cells(1).CurrentRegion.Columns("f:g").Value
    For i = 2 To UBound(a, 1)
        If Not dic.exists(a(i, 1)) Then
            Set dic(a(i, 1)) = CreateObject("System.Collections.ArrayList")
        End If
        dic(a(i, 1)).Add a(i, 2)
    Next
    With Sheets("sheet2").Cells(1).CurrentRegion
        .Offset(1, 5).ClearContents
        a = .Value
        For i = 2 To UBound(a, 1)
            If dic.exists(a(i, 1)) Then
                For ii = 6 To UBound(a, 2)
                    If a(1, ii) Like "Time*" Then
                        If dic(a(i, 1)).Count Then
                            a(i, ii) = dic(a(i, 1))(0)
                            dic(a(i, 1)).RemoveAt 0
                            If dic(a(i, 1)).Count = 0 Then Exit For
                        End If
                    End If
                Next
            End If
        Next
        .Value = a
    End With
End Sub

**dunnobe** · 01-10-2018, 10:31 AM

Very nice, but 100% Japanese to me!

rep +1

Is there any1 who knows another method so I can compare and learn?

**jindon** · 01-10-2018, 10:36 AM

I think I missed this part

count the amount of times you find this date

Sub test()
    Dim a, i As Long, ii As Long, dic As Object
    Set dic = CreateObject("Scripting.Dictionary")
    a = Sheets("sheet3").Cells(1).CurrentRegion.Columns("f:g").Value
    For i = 2 To UBound(a, 1)
        If Not dic.exists(a(i, 1)) Then
            Set dic(a(i, 1)) = CreateObject("System.Collections.ArrayList")
        End If
        dic(a(i, 1)).Add a(i, 2)
    Next
    With Sheets("sheet2").Cells(1).CurrentRegion
        .Offset(1, 5).ClearContents
        a = .Value
        For i = 2 To UBound(a, 1)
            If dic.exists(a(i, 1)) Then
                a(i, 5) = dic(a(i, 1)).Count
                For ii = 6 To UBound(a, 2)
                    If a(1, ii) Like "Time*" Then
                        If dic(a(i, 1)).Count Then
                            a(i, ii) = dic(a(i, 1))(0)
                            dic(a(i, 1)).RemoveAt 0
                            If dic(a(i, 1)).Count = 0 Then Exit For
                        End If
                    End If
                Next
            Else
                a(i, 5) = 0
            End If
        Next
        .Value = a
    End With
End Sub

**dunnobe** · 01-10-2018, 10:41 AM

Mmm, the result seems to be the same?

(Which is good in this case)

**jindon** · 01-10-2018, 10:47 AM

Slower but easier to understnad?

Sub test()
    Dim rng1 As Range, rng2 As Range, r As Range, c As Range,  ff As String
    Set rng1 = Sheets("sheet2").Cells(1).CurrentRegion
    Set rng2 = Sheets("sheet3").Cells(1).CurrentRegion.Columns("f")
    rng1.Offset(1, 4).ClearContents
    For Each r In rng1.Columns(1).Cells
        If IsDate(r.Value) Then
            Set c = rng2.Find(r.Value, , xlFormulas)
            If Not c Is Nothing Then
                ff = c.Address
                Do
                    r(, 5) = r(, 5) + 1
                    r.Offset(, r(, 5) * 5).Value = c(, 2).Value
                    Set c = rng2.FindNext(c)
                Loop Until c.Address = ff
            Else
                r(, 5) = 0
            End If
        End If
    Next
End Sub

**dunnobe** · 01-11-2018, 06:12 AM

Hey jindon,

Thank you. I modified it a little bit to fit my needs.

I do have a few general questions:

1) It drops the 0 in front of a number (e.g. 97 rather than 097 in the columns Code1, Code2 etc.)
How can I fix this?

2) Do programmers turn data into a table before or after creating all of the data?

3) Do programmers format the data during creation or after creating all of the data?
E.g. I did ws2.Cells.Clear made me lose my formatting of ws2.

Should I do ws2.Cells.ClearContents instead and preformat it myself? Should I insert formatting when creating the data?
Should I just format everything after the data was created?

Sub test()
    Dim rng1 As Range, rng2 As Range, r As Range, c As Range, ff As String
    
   Application.ScreenUpdating = False
    
    Set rng1 = Sheets("sheet2").Cells(1).CurrentRegion
    Set rng2 = Sheets("sheet3").Cells(1).CurrentRegion.Columns("f")
    rng1.Offset(1, 4).ClearContents
    For Each r In rng1.Columns(1).Cells
        If IsDate(r.Value) Then
            Set c = rng2.Find(r.Value, , xlFormulas)
            If Not c Is Nothing Then
                ff = c.Address
                Do
                    r(, 5) = r(, 5) + 1
                    
                    r.Offset(, r(, 5) * 5).Value = c(, 2).Value
                    r.Offset(, r(, 5) * 5 + 1).Value = c(, 4).Value
                    r.Offset(, r(, 5) * 5 + 2).Value = c(, 6).Value
                    r.Offset(, r(, 5) * 5 + 3).Value = c(, 7).Value
                    r.Offset(, r(, 5) * 5 + 4).Value = c(, 13).Value
                    
                    Set c = rng2.FindNext(c)
                Loop Until c.Address = ff
            Else
                r(, 5) = 0
            End If
        End If
    Next

   Application.ScreenUpdating = True

End Sub

**jindon** · 01-11-2018, 06:29 AM

Then why not reverse to copy...

                    c(, 2).copy r.Offset(, r(, 5) * 5)
                    c(, 4).copy r.Offset(, r(, 5) * 5 + 1)
                    ...etc...

**dunnobe** · 01-11-2018, 08:47 AM

Hey jindon,

I'm very new to VBA. I'm just doing some learning by doing and studying other's work. I haven't really followed a course yet, might I might soon for work.
This is only the 2nd attempt to make a tool so I was already happy to make some working loops. :p

Copying seems to be slower, but I like the result better.
Very nifty code and I made some additional changes to replace my code by this one.

Sub final()
    Dim rng1 As Range, rng2 As Range, rng3 As Range, r As Range, c As Range, d As Range
    Dim ff As String, gg As String
    
    Application.ScreenUpdating = False
    
    Set rng1 = Sheets("sheet2").Cells(1).CurrentRegion
    Set rng2 = Sheets("sheet3").Cells(1).CurrentRegion.Columns("f")
    Set rng3 = Sheets("sheet1").Cells(1).CurrentRegion.Columns("g")
    rng1.Offset(1, 4).ClearContents
    For Each r In rng1.Columns(1).Cells
        If IsDate(r.Value) Then
            
            Set d = rng3.Find(r.Value, , xlFormulas)
            If Not d Is Nothing Then
                gg = d.Address
                Do
                    
                    d(, 8).Copy r.Offset(, 2)
                    d(, 3).Copy r.Offset(, 3)

                    Set d = rng3.FindNext(d)
                Loop Until d.Address = gg
            Else
                r(, 3) = 0
                r(, 4) = 0
            End If

            Set c = rng2.Find(r.Value, , xlFormulas)
            If Not c Is Nothing Then
                ff = c.Address
                Do
                    r(, 5) = r(, 5) + 1

                    c(, 2).Copy r.Offset(, r(, 5) * 5)
                    c(, 4).Copy r.Offset(, r(, 5) * 5 + 1)
                    c(, 6).Copy r.Offset(, r(, 5) * 5 + 2)
                    c(, 7).Copy r.Offset(, r(, 5) * 5 + 3)
                    c(, 13).Copy r.Offset(, r(, 5) * 5 + 4)
                                        
                    Set c = rng2.FindNext(c)
                Loop Until c.Address = ff
            Else
                r(, 5) = 0
            End If
        End If
    Next

    Application.ScreenUpdating = True

End Sub

2 questions:

1) Does this server a purpose? I guess not as I don't need the value 0 in column 3 and 4?

r(, 3) = 0
r(, 4) = 0

2) The result in ws2.cells(2, 4) for the date 3/07/2017 is "ZE-Zending".
When you look at ws1 you see that this date has 2 values "Var 7h36" and "ZE-Zending".
"ZE-Zending" is the right, but why does it take this one and not the other one?

**jindon** · 01-11-2018, 08:55 AM


                    c(, 2).Copy r.Offset(, r(, 5) * 5)
                    c(, 4).Copy r.Offset(, r(, 5) * 5 + 1)
                    c(, 6).Copy r.Offset(, r(, 5) * 5 + 2)
                    c(, 7).Copy r.Offset(, r(, 5) * 5 + 3)
                    c(, 13).Copy r.Offset(, r(, 5) * 5 + 4)

could be

                    Union(c(, 2), c(, 4), c(, 6), c(, 7), c(, 13)).Copy r.Offset(, r(, 5) * 5)

bit faster?

**jindon** · 01-11-2018, 09:24 AM

Because, it updates when next matched date is found.

            Set d = rng3.Find(r.Value, , xlFormulas)
            ' don't look for next match
            If Not d Is Nothing Then  
                    union(d(, 8), d(, 3)).Copy r.Offset(, 2)
            Else
                r(, 3).resize(,2) = 0
            End If

Too slow anyway...

**dunnobe** · 01-11-2018, 09:33 AM

Oh yes, I used a count time macro and that's definitely faster (about 4 secs).

Thanks for showing different ways to achieve the same result!

**dunnobe** · 01-23-2018, 06:36 AM

Hey jindon,

I encountered a strange problem with Set c = rng2.Find(r.Value, , xlFormulas)
If r.value = 15/01/2016, it sets c = 15/11/2016 and thus starts copying the values for both 15/01/2016 and 15/11/2016.

E.g.

15/01/2016: it shows the 2 timestamps of 15/01/2016 and the 4 timestamps of 15/11/2016!

I highlighted some of these strange cases in red in wsSummary.

Would you mind having another look?


' Create the data for column C till last in wsSummary
' ---------------------------------------------------

    Dim rng1 As Range, rng2 As Range, rng3 As Range, r As Range, c As Range, d As Range
    Dim ff As String, gg As String

    Set rng1 = wsSummary.Cells(1).CurrentRegion
    Set rng2 = wsTime.Cells(1).CurrentRegion.Columns("f")
    Set rng3 = wsPlanification.Cells(2).CurrentRegion.Columns("g")
    rng1.Offset(1, 4).ClearContents
    For Each r In rng1.Columns(1).Cells
        If IsDate(r.Value) Then
           
            Set c = rng2.Find(r.Value, , xlFormulas)
            If Not c Is Nothing Then
                ff = c.Address
                Do
                    r(, 5) = r(, 5) + 1
'
'                    c(, 2).Copy r.Offset(, r(, 5) * 5)
'                    c(, 4).Copy r.Offset(, r(, 5) * 5 + 1)
'                    c(, 6).Copy r.Offset(, r(, 5) * 5 + 2)
'                    c(, 7).Copy r.Offset(, r(, 5) * 5 + 3)
'                    c(, 13).Copy r.Offset(, r(, 5) * 5 + 4)

                    Union(c(, 2), c(, 4), c(, 6), c(, 7), c(, 13)).Copy r.Offset(, r(, 5) * 5)

                    Set c = rng2.FindNext(c)
                Loop Until c.Address = ff
            Else
                r(, 5) = 0
            End If
        End If
    Next

SOLVED Set c = rng2.Find(r.Value, , xlFormulas, xlWhole)

Transpose vertical to horizontal data based on countif?

LinkBack

Thread Tools

Rate This Thread

Display

Hybrid View

Transpose vertical to horizontal data based on countif?

Re: Transpose vertical to horizontal data based on countif?

Re: Transpose vertical to horizontal data based on countif?

Re: Transpose vertical to horizontal data based on countif?

Re: Transpose vertical to horizontal data based on countif?

Re: Transpose vertical to horizontal data based on countif?

Re: Transpose vertical to horizontal data based on countif?

Re: Transpose vertical to horizontal data based on countif?

Re: Transpose vertical to horizontal data based on countif?

Re: Transpose vertical to horizontal data based on countif?

Re: Transpose vertical to horizontal data based on countif?

Re: Transpose vertical to horizontal data based on countif?

Re: Transpose vertical to horizontal data based on countif?

Thread Information

Users Browsing this Thread

Similar Threads

Transpose huge data from horizontal to vertical

[SOLVED] Transpose data from horizontal to vertical in specific column

[SOLVED] Transpose vertical data into horizontal records vba

[SOLVED] Data transpose (from vertical input to Horizontal output)

Transpose Vertical Data to Horizontal

Convert a portion of data from horizontal to vertical but not all (cant use transpose)

[SOLVED] transpose data from horizontal to vertical in a specific column

Bookmarks

Bookmarks

Posting Permissions