Looping through rows and then by columns

[Taul]

Hi,
I could do with some assistance please. I have data laid out as follows:-
Headers in row 5 and Data in columns A to T (approx. 300 rows of data)
Column A will always shave data in it, so I’m using that column to reference the “lastrow”
Columns G to K will have company names (with some blank) and I need to loop through column G and for each occurrence of data (a company name) I need to paste the company name in the next available row in column F and then repeat for columns H, I J & K
The code I have so far works for the first column but using the offset command pastes the wrong data to column A to E
Can anyone assist in getting a loop within a loop to work correctly please.
I have a feeling it may involve using two variable j & i but I can’t figure that out.

The blue text is not working, so ...
Up to Row 12 is the source data,
Row 13 and below is what is required after the macro is run (should have been blue)


Excel 2010

	A	B	C	D	E	F	G	H	I	J	K
5	Date	Module	Name	Category	Project	Fab 1	Fab 2	Fab 3	Fab 4	Fab 5	Fab 6
6	19-04-18	R1	GWA	BW	Project 1	Fab 1	Fab 2
7	24-04-18	R1	GWA	BW	Project 2	Fab 2
8	25-04-18	R3	MCK	RY	Project 3	Fab 3	Fab 6	Fab 9
9	11-04-18	R4	AF	CV	Project 4	Fab 2	Fab 3
10	11-04-18	R4	AF	CV	Project 5	Fab 5	Fab 7	Fab 6
11	12-04-18	R4	AF	CV	Project 6	Fab 6	Fab 2
12	16-04-18	R4	AF	CV	Project 7	Fab 7
13	19-04-18	Row 6	GWA	BW	Project 1	Fab 2
14	25-04-18	Row 8	MCK	RY	Project 3	Fab 6
15	11-04-18	Row 9	AF	CV	Project 4	Fab 3
16	11-04-18	Row 10	AF	CV	Project 5	Fab 7
17	12-04-18	Row 11	AF	CV	Project 6	Fab 2
18	25-04-18	Row 8	MCK	RY	Project 3	Fab 9
19	11-04-18	Row 10	AF	CV	Project 5	Fab 6
20
21	After macro runs, the data in BLUE should be pasted

<tbody>
</tbody>

Sheet1​

Sub AlignFabs()
'Application.ScreenUpdating = False
'Application.Calculation = xlCalculationManual
''**** Loop Through Rows of Fab Names ****
For Each Col In Array("G", "H", "I", "J", "K")
cntr = 0
 
For Each co In Sheet1.Range(Col & "6:" & Col & Sheet1.Range(Col & "65536").End(xlUp).Row + 0)
    lastrow = Sheet1.Range("A65536").End(xlUp).Offset(1, 0).Row 'define the row increment on the Destination sheet
   
    If co.Offset(0, 0).Value <> "" Then
        Sheet1.Range("A" & lastrow).Value = co.Offset(0, -6) 'Date
        Sheet1.Range("B" & lastrow).Value = "Copy" 'ideally paste the row number it came from
        Sheet1.Range("C" & lastrow).Value = co.Offset(0, -4) 'Name
        Sheet1.Range("D" & lastrow).Value = co.Offset(0, -3) 'Category
        Sheet1.Range("E" & lastrow).Value = co.Offset(0, -2) 'Project
        Sheet1.Range("F" & lastrow).Value = co.Offset(0, 0) 'Fab1 column F
    End If
cntr = cntr + 1
Next co
Next Col
'Application.Calculation = xlCalculationAutomatic
'Application.ScreenUpdating = True
End Sub

 

[Fluff]

How about

Sub AlignFabs()
Dim cntr As Long
'Application.ScreenUpdating = False
'Application.Calculation = xlCalculationManual
''**** Loop Through Rows of Fab Names ****
cntr = 0

For Each col In Array("G", "H", "I", "J", "K")
 
For Each Co In Sheet6.Range(col & "6:" & col & Sheet6.Range(col & "65536").End(xlUp).Row + 0)
    lastRow = Sheet6.Range("A65536").End(xlUp).Offset(1, 0).Row 'define the row increment on the Destination sheet
   
    If Co.Offset(0, 0).Value <> "" Then
        Sheet6.Range("A" & lastRow).Value = Co.Offset(0, -6 - cntr) 'Date
        Sheet6.Range("B" & lastRow).Value = "Copy" 'ideally paste the row number it came from
        Sheet6.Range("C" & lastRow).Value = Co.Offset(0, -4 - cntr) 'Name
        Sheet6.Range("D" & lastRow).Value = Co.Offset(0, -3) 'Category
        Sheet6.Range("E" & lastRow).Value = Co.Offset(0, -2) 'Project
        Sheet6.Range("F" & lastRow).Value = Co.Offset(0, 0) 'Fab1 column F
    End If
Next Co
cntr = cntr + 1
Next col
'Application.Calculation = xlCalculationAutomatic
'Application.ScreenUpdating = True
End Sub

 

[Taul]

Thank you Fluff,
I hadn't thought of -cntr, good call.
I will check it out on Monday when I return to work.

Many thanks
Paul

 

[Fluff]

Do the extra rows need to go at the bottom of the data, or would you be happy with inserting new rows below the existing rows, like

Excel 2013 32 bit
	A	B	C	D	E	F	G	H	I	J	K	L
1	5	Date	Module	Name	Category	Project	Fab 1	Fab 2	Fab 3	Fab 4	Fab 5	Fab 6
2	6	19/04/2018	R1	GWA	BW	Project 1	Fab 1	Fab 2
3	7	19/04/2018	R1	GWA	BW	Project 1	Fab 2
4	8	24/04/2018	R1	GWA	BW	Project 2	Fab 2
5	9	25/04/2018	R3	MCK	RY	Project 3	Fab 3	Fab 6	Fab 9
6	10	25/04/2018	R3	MCK	RY	Project 3	Fab 6
7	11	25/04/2018	R3	MCK	RY	Project 3	Fab9
Combined

 

[Fluff]

If you are interested in the above idea, try

 Sub TransposeData()
   Dim Cl As Range
   Dim Rws As Long
   Dim i As Long
   
   For i = Range("A" & Rows.Count).End(xlUp).Row To 6 Step -1
      Rws = Application.CountA(Range("G" & i).Resize(, 5))
      If Rws > 0 Then
         Rows(i + 1).Resize(Rws).Insert
         Range("A" & i).Resize(Rws + 1, 5).FillDown
         Range("F" & i + 1).Resize(Rws).Value = Application.Transpose(Range("G" & i).Resize(, Rws))
      End If
   Next i
  [COLOR=#ff0000] Range("G:K").Clear[/COLOR]
 End Sub

Remove the line in red if you want to keep the data in cols G:K

 

[Taul]

Thank you Fluff,
That's an interesting approach that I hadn't considered.
Just to put more meat on the bones, this whole report is connecting to a shared Outlook Calendar and pulling in all the appointments between specified dates. The Appointment form in Outlook has a custom page with additional drop-downs and text boxes. So the Excel report page (a sample section of it is shown on the original post) also has other formula that are applied at the run time and feed into other pages and graphs on the report, so although your approach is sensible, making the change at this stage would involve making loads of changes to the way the whole report runs. I think your suggestion has now made me realise that I could have laid it out better but I think I will stick to my current approach, if only to avoid the pain of changing it.
But I really appreciate the assistance you have provided.

I may feel different on Monday morning when I run this and with the benefit of a weekend off, I may adopt your approach.

cheers
Paul.

 

[Fluff]

That's fair enough.
Let me know how it goes.