VBA to put vertical info into horizontal

[Jeeremy7]

Hello guys

So we were pulling data from our software into excel and a macro was formatting this data in a way so an other sheet could pick up this info
Sadly the software changed the formatting an now the data is in vertical instead of horizontal.
I've been trying to make it work but I have found no solutions..

This is how it was supposed to look

TEMPLATE New WIP Template calculation (06-30-2020) All Data updated reconciled - new WIP calc.xlsm
	A	B	C	D	E	F
2	18108	123	240116.4	-130391.64	-602945.42	-5136162.93
3	18109	1234	-98.3	-3374.85	-20216.39	-657788.22
4	18121	12345	428.45	-	-101241.12	-1178046.13
5	18169	123456	-1947.22	-1947.22	-1094.67	-19339.16
6	18172	1234567	-144047.58	-3039456.8	-221709.35	-4640675.21
7	18193	12345678	-2000	-11610	-17985.98	-70261.09
8	18200	123456789	-437725.71	-10424337	-1342824.86	-38335480.84
Jonas Data

This is how it's looking now

New WIP Template calculation (06-30-2020) All Data updated reconciled - new WIP calc.xlsm
	A	B	C	D
1	18108	1234
2		Total Revenue	-3,106,008.26	-37,421,232.76
3		TOTAL	-113,399.05	-1,186,783.90
4	18121	12345
5		Total Revenue	-139,684.51	-3,104,877.79
6		TOTAL	-38,368.22	-355,292.44
7	18169	123456
8		TOTAL	3,374.66	-53,428.64
9	18172	1234567
10		TOTAL	911	-56,480.27
11	18193	12345678
12		Total Revenue	-149,500.94	-657,278.66
13		TOTAL	-108,434.43	-129,853.75
14	18200	123456789
Jonas Data

I've put the color so you know which data is supposed to go where.

Now the data here is already simplified by some macro (that's pretty slow) but that would be an other problem I don't want to ask for too much

Thanks a lot for whoever will take the time

 

[Fluff]

How about

Sub Jeeremy()
   Dim Rng As Range, Cl As Range
   For Each Rng In Range("C:C").SpecialCells(xlConstants).Areas
      If Rng.Count = 1 Then
         Rng.Offset(-1) = Rng
         Rng.Offset(-1, 2) = Rng.Offset(, 1)
      Else
         Rng.Offset(-1).Resize(1) = Rng(2)
         Rng.Offset(-1, 1).Resize(1) = Rng(1)
         Rng.Offset(-1, 2).Resize(1) = Rng.Offset(, 1)(2)
         Rng.Offset(-1, 3).Resize(1) = Rng.Offset(, 1)(1)
      End If
   Next Rng
   Range("A:A").SpecialCells(xlBlanks).EntireRow.Delete
End Sub

 

[Jeeremy7]

Wow that's exactly what I needed :D
Amazing how simple it can look when written

Since I'm here if you don't mind answering an other question

This in the same macro to simplify the data at the beginning

' Delete COMM Communications values in colum A
    lr = Cells(Rows.Count, "A").End(xlUp).Row
    For r = lr To 1 Step -1
    If Cells(r, "A") = "COMM Communications" Then
    Rows(r).Delete
    End If
    Next r
    
' Delete LAB Labourers values in colum A
    lr = Cells(Rows.Count, "A").End(xlUp).Row
    For r = lr To 1 Step -1
    If Cells(r, "A") = "LAB Labourers" Then
    Rows(r).Delete
    End If
    Next r
    
' Delete OTH Other values in colum A
    lr = Cells(Rows.Count, "A").End(xlUp).Row
    For r = lr To 1 Step -1
    If Cells(r, "A") = "OTH Other" Then
    Rows(r).Delete
    End If
    Next r
    
' Delete RENT Rentals values in colum A
    lr = Cells(Rows.Count, "A").End(xlUp).Row
    For r = lr To 1 Step -1
    If Cells(r, "A") = "RENT Rentals" Then
    Rows(r).Delete
    End If
    Next r

Is there a "OR" or "AND" formula I could put to have it all on the same command ?

I have around 8,000 lines and more delete commands so the macro is taking quite a while ..

Thanks again

 

[Fluff]

Does your data have a header row?

 

[Jeeremy7]

I does but I can do a macro to delete it because I need to make a new one with the correct format

 

[Fluff]

Don't delete it, try

Sub Jeeremy2()
   Dim UsdRws As Long
   
   With ActiveSheet
      UsdRws = .Range("A" & Rows.Count).End(xlUp).Row
      .Range("A1:A" & UsdRws).AutoFilter 1, Array("COMM Communications", "LAB Labourers", "OTH Other", "RENT Rentals"), xlFilterValues
      .AutoFilter.Range.Offset(1).EntireRow.Delete
      .AutoFilterMode = False
   End With
End Sub

 

[Jeeremy7]

Yes that's perfect

I have other issues but I may wait till Monday and try to figure it out today but not sure I can .. haha

Thanks a lot Fluff

 

[Fluff]

You're welcome & thanks for the feedback.