Column data transfer in for next loop

[rjplante]

I have a table in Sheet 1 that has 119 columns of data. I need to transfer each block of columns to Sheet 2 so that the column heading is now a row heading and the data in my row is transferred to the columns to the right of the row header. I have some columns of data that are a single column, others have six columns of data in them. My code listed below, crashes on the following line:

Sheet8.Range("B2").End(xlDown).Offset(1, 0).Range(ActiveCell, Resize(1, 7)).Value = Sheets("Master").Range(ActiveCell, Resize(1, 7)).Value

I don't know what I need to do to correct this line. I also have my copy and paste areas in the image below.

Sub Gantt_Transfer()

Application.ScreenUpdating = False

Dim StartCol As Long
Dim sh As Worksheet
Dim ColCnt As Integer
Dim myRow As Long

'   Clear Existing Fields
    Sheets("Full Gantt Chart").Range("A3:F35").ClearContents
    Sheets("Full Gantt Chart").Range("AN2:AN6").ClearContents


'   Job Number Transfer Column A
    Sheet8.Range("AO2").Value = Sheets("Master").Range("A" & ActiveCell.Row).Value
'   Reason for Team Transfer Column B
    Sheet8.Range("AO6").Value = Sheets("Master").Range("B" & ActiveCell.Row).Value
'   Company Name Transfer Column C
    Sheet8.Range("AO3").Value = Sheets("Master").Range("C" & ActiveCell.Row).Value
'   Rev Transfer Column D
    Sheet8.Range("AO4").Value = Sheets("Master").Range("D" & ActiveCell.Row).Value
'   Reason for Rev Transfer Column E
    Sheet8.Range("AO5").Value = Sheets("Master").Range("E" & ActiveCell.Row).Value


'================================================================================
    Set sh = ActiveSheet
    StartCol = sh.Columns(6).Column
    myRow = ActiveCell.Row
    

'   Data Transfer
    Sheets("Master").Cells(myRow, StartCol).Select
    
    For ColCnt = 0 To 113 Step 1
    
    If ActiveCell.Column = 120 Then Exit Sub
    
    If ActiveCell.Value = "" Then
        ActiveCell.Offset(0, 1).Select
    ElseIf Sheets("Master").Cells(2, ActiveCell.Column).Value = "Milestone" Then
        If Sheet8.Range("A3").Value = "" Then
            Sheet8.Range("A3").Value = Sheets("Master").Cells(1, ActiveCell.Column).Value
            Sheet8.Range("B3").Value = ActiveCell.Value
            Sheet8.Range("C3").Value = 1
            Sheet8.Range("D3").Value = ActiveCell.Value
            Sheet8.Range("E3").Value = ActiveCell.Value
            Sheet8.Range("F3").Value = 1
            Sheet8.Range("G3").Value = ActiveCell.Value
            
        Else
            Sheet8.Range("A2").End(xlDown).Offset(1, 0).Value = Sheets("Master").Cells(1, ActiveCell.Column).Value
            Sheet8.Range("B2").End(xlDown).Offset(1, 0).Value = ActiveCell.Value
            Sheet8.Range("C2").End(xlDown).Offset(1, 0).Value = 1
            Sheet8.Range("D2").End(xlDown).Offset(1, 0).Value = ActiveCell.Value
            Sheet8.Range("E2").End(xlDown).Offset(1, 0).Value = ActiveCell.Value
            Sheet8.Range("F2").End(xlDown).Offset(1, 0).Value = 1
            Sheet8.Range("G2").End(xlDown).Offset(1, 0).Value = ActiveCell.Value
        End If
        ActiveCell.Offset(0, 1).Select
    Else
        If Sheet8.Range("A3").Value = "" Then
            Sheet8.Range("A3").Value = Sheets("Master").Cells(1, ActiveCell.Column).Value
            Sheet8.Range("B3:F3").Value = Sheets("Master").Columns(ActiveCell.Column).Resize(1, 7).Value
        Else
            Sheet8.Range("A2").End(xlDown).Offset(1, 0).Value = Sheets("Master").Cells(1, ActiveCell.Column).Value
            Sheet8.Range("B2").End(xlDown).Offset(1, 0).Range(ActiveCell, Resize(1, 7)).Value = Sheets("Master").Range(ActiveCell, Resize(1, 7)).Value
        End If
        ActiveCell.Offset(0, 6).Select
        
    End If
    
    Next ColCnt

    Sheet8.Activate
   
Application.ScreenUpdating = True

End Sub

Master Data Table:

Machine Follow-Up Test.xlsm
	A	B	C	D	E	F	G	H	I	J	K	L	M
1	JOB #	Team	Company	Rev.	Reason for Rev	Receive PO and Down Payment (Project Start Date)	Kick off	Mechanical Design Output			Mechanical Design Output
2						Milestone	Milestone	Plan	Plan	Plan	Actual	Actual	Actual
3						End Date	End Date	Start Date	# Working days	End Date	Start Date	# Working days	End Date
4	111	3	AAA	A	Quote ABC-123	11-Mar-2020	16-Mar-2020	16-Mar-2020	15	6-Apr-2020	16-Mar-2020	15	6-Apr-2020
5	222	3	BBB	A		20-Feb-2020	23-Mar-2020	23-Mar-2020	10	6-Apr-2020	23-Mar-2020	10	6-Apr-2020
6	333	2	VCCC	C	Change Order 05-MAY-2020	1-Apr-2019	22-Apr-2019	22-Apr-2019	12	8-May-2019	22-Apr-2019	12	8-May-2019
7	444		DDD
8	555		EEE
9	666	3	FFF
10	777	1	GGG	A		20-Nov-2019	2-Dec-2019	2-Dec-2019	7	11-Dec-2019	2-Dec-2019	7	11-Dec-2019
11	888		HHH
12	999	3	III	C	Updated Spec 4/1/2020	2-Nov-2018	10-Feb-2018	10-Feb-2018	20	9-Mar-2018	10-Feb-2018	20	9-Mar-2018
13	0	3	JJJ	E	Updated Mechanical 3/25/2020	7-Mar-2019	27-Mar-2019	27-Mar-2019	25	1-May-2019	27-Mar-2019	25	1-May-2019
14
15
Master (2)

Cell Formulas
Range	Formula
J4:J13,M4:M13	J4	=IF(H4="","",WORKDAY(H4,I4,Data!$F$2:$F$113))

Cells with Conditional Formatting
Cell	Condition		Cell Format	Stop If True
A11:DP11	Expression	=COLUMN(A13)=SelCol	text	NO
A11:DP11	Expression	=ROW(A11)=SelRow	text	NO
L3	Expression	=COLUMN(L5)=SelCol	text	NO
M3	Expression	=COLUMN(M5)=SelCol	text	NO
I3	Expression	=COLUMN(I5)=SelCol	text	NO
A3:H3,AA3:AC3,AI3:AJ3,BB3,AP3,AV3,BH3,BT3:BU3,BN3,CA3,CG3:CI3,CO3,DB3,N3,T3:U3,CU3:CV3,DH3:DJ3,A282:DP1048572,J3:K3,P3:Q3,DP3:DP10,A4:DO10,A13:DP279	Expression	=COLUMN(A5)=SelCol	text	NO
A280:AK280,A281:BG490,BH280:DO490,AN280:BC280,A4:DP10,DP12:DP490,A12:DO279	Expression	=ROW(A4)=SelRow	text	NO
A281:DP281,A12:DP12	Expression	=COLUMN(A13)=SelCol	text	NO
A1:H1,BB1:BC1,DP1:DP2,AA2:AB2,AI2,BT2,CG2:CH2,CU2,DH2:DI2,A2:T2,N1:P1,T1:W1,AA1:AE1,AI1:AL1,AP1:AR1,AV1:AX1,BH1:BJ1,BN1:BP1,BT1:BW1,CA1:CC1,CG1:CK1,CO1:CQ1,CU1:CX1,DB1:DD1,DH1:DL1,DP1048574:DP1048576	Expression	=COLUMN(A4)=SelCol	text	NO

Here is the destination workbook:

Machine Follow-Up Test.xlsm
	A	B	C	D	E	F	G
1		Plan	Plan	Plan	Actual	Actual	Actual
2	Description	Start Date	# Working Days	End Date	Start Date	# Working Days	End Date
3	Receive PO and Down Payment (Project Start Date)	18-Feb-2020	1	18-Feb-2020	18-Feb-2020	1	18-Feb-2020
4	Kick off	10-Feb-2018	1	10-Feb-2018	10-Feb-2018	1	10-Feb-2018
5	Mechanical Design Output	27-Mar-2019	25	1-May-2019	1-Apr-2019	25	6-May-2019
6
7
8
9
10
11
12
13
14
15
Full Gantt Chart

Cell Formulas
Range	Formula
D5	D5	=IF(B5="","",WORKDAY(B5,C5,Data!$F$2:$F$113))

Cells with Conditional Formatting
Cell	Condition		Cell Format	Stop If True
B5:G5	Expression	=COLUMN(B7)=SelCol	text	NO
B5:G5	Expression	=ROW(B5)=SelRow	text	NO

Thanks for the help.

 

[Rijnsent]

Hi rjplante,

What range are you trying to copy with that line?
Sheet8.Range("B2").End(xlDown).Offset(1, 0).Range(ActiveCell, Resize(1, 7)).Value = Sheets("Master").Range(ActiveCell, Resize(1, 7)).Value
This is the main culprit:
.Range(ActiveCell, Resize(1, 7))
Inside a Range object you can have either a "text", e.g. "B2" or 2 cell-objects. Resize(1,7) is not a cell object and ActiveCell refers to the active cell, that's probably not what you're looking for. I guess you want:
Sheet8.Range("B2").End(xlDown).Offset(1, 0).Resize(1, 7).Value = Sheets("Master").Cells(1, ActiveCell.Column).Resize(1, 7).Value

Hope that works,
Koen

 

[rjplante]

Koen,

I am trying to transfer the data from the active cell (for company GGG) and the cells from the next 5 columns (in my table columns H-M) over to my chart table and have them placed in the first available row in columns B-G. I appreciate the clarification in the line above. I have made a correction in mine below, but it doesn't transfer the data correctly. I get the header in column A from the first row and my active cell column, but none of the dates come across.

Sub TEST_ME()

        If Sheet8.Range("A3").Value = "" Then
            Sheet8.Range("A3").Value = Sheets("Master").Cells(1, ActiveCell.Column).Value
            Sheet8.Range("B3").Resize(1, 7).Value = Sheets("Master").Cells(ActiveCell.Column, ActiveCell.Row).Resize(1, 7).Value
        Else
            Sheet8.Range("A2").End(xlDown).Offset(1, 0).Value = Sheets("Master").Cells(1, ActiveCell.Column).Value
            Sheet8.Range("B2").End(xlDown).Offset(1, 0).Resize(1, 7).Value = Sheets("Master").Cells(ActiveCell.Column, ActiveCell.Row).Resize(1, 7).Value
        End If
        
End Sub

Thanks for looking and providing a possible solution.

 

[Rijnsent]

Hi RJ,
I see a couple of things in your code that might be the culprit, I am not sure which it is as I lack your sheets, but give these options a try (living by the proverb "Give a man a fish, and you feed him for a day. Teach a man to fish, and you feed him for a lifetime.":

• firstly, step through your code with F8 (in the VBA editor: ALT+F11), don't run it by pressing run macro/play/F5, so you can see step by step what's happening
• Secondly, this is probably wrong, as a Cell object is Cell(Row, Column) -> Sheets("Master").Cells(ActiveCell.Column, ActiveCell.Row) flips that probably unintended
• Thirdly: try to avoid using ActiveCell and .Select statements. If you use the macro recorder they are recorded a lot, but in practical coding they give uncertain and slow outcomes, as a user might click somewhere unexpected and all the selecting is not needed for the code to work.
• Add some lines like this (output will be in the VBA editor in the Direct window (which you can show through the View menu in VBA)

  Debug.Print "1: " & sheet8.Range("B2").Address
  Debug.Print "2: " & sheet8.Range("B2").End(xlDown).Address
  Debug.Print "3: " & sheet8.Range("B2").End(xlDown).Offset(1, 0).Address
  Debug.Print sheet8.Range("B2").End(xlDown).Offset(1, 0).Resize(1, 7).Address

  It should give you something like:
  

  1: $B$2
  2: $B$7
  3: $B$8
  $B$8:$H$8

  That basically shows how your address is built up (so which region is copied and where it is copied to), that should help you finding out what goes wrong

Hope that works (and will provide you with lots of fish in the future ),
Koen

 

[rjplante]

Koen,
Thanks for the fishing pole. It was my cells reference, I did have it column then row instead of the other way around. Once I fixed that, magic started happening. It is a beautiful thing. I do appreciate your coaching.

 

[Rijnsent]

Debugging is often a mind-boggling & frustrating puzzle (although you get better at it with practice). But when you can sit back, have a 5 minute coffee while your macro is running and doing the work that would take others days to complete, that's indeed a majestic feeling .
Cheers,
Koen