Data table transfer loop

[rjplante]

I have a large table of data and I want to move it over to a charting table. I have the data I want to move in groups of 6 columns. I also have in row two, a merged cell over the block of six columns that the user can click a button and enter the word "YES" in the first cell in the merged block. See the Master data table below.

I have my master workbook set up so that when the user selects a cell the entire row highlights. This allows the user to see which group the user has selected. I will try to describe the steps in my transfer of data below along with my current code.

STEP 1: Apply filter based on group number.
STEP 2: Sort remaining data based on Job number.
STEP 3: Starting from the cell A2, move to the first block of 6 columns.
STEP 4: Filter out the blank rows of data based on the first column of the block of 6 columns.
STEP 5: Transfer the block of job numbers to column A on the Chart worksheet. If cell A3 is blank, paste the data from column A on the Master into A3 on the Chart. If A3 on the Chart is full, go to the last row in A, skip a row, and then paste the data in that row.
5a: The Data in column A on the Chart page is the block of filtered and sorted job numbers from the Master table (I don't know if this block of data can be declared up top [Dim Jobs As Range] and then used to paste that
block into the chart table in column A.
STEP 6: Transfer the data from the block of 6 columns on the Master page over to the Chart page. If B3 is blank, paste the data from the block of 6 into B3:G3. If B3 is full go to the last row in B, skip a row, and then paste the data in that row.
STEP 7: Transfer the column Data Title from the first column on the block of 6 and from the first row in that block. This will be pasted into column H on the Chart page. Once pasted into the first row of the data block, I would like the data in that cell to to be filled down to the last row in the of the block of data.
STEP 8: [Begin Loop] On the Master table, move to the next block of 6 columns and transfer that block of data to the chart page. (This needs to be cell reference independent because the blocks of 6 columns selected may change from day to day. Sometimes there may be a single block, and others 6 separate blocks. It should be looped from column 1 to column 120 using row 2 as the search row.)

The code below was originally set up to only transfer the data based on the row and column selected on the master table, and would only transfer a single block of six columns. I need it to be modified to complete the above 8 steps.

Current Macro:

Sub Group_Transfer()

Application.ScreenUpdating = False
Application.EnableEvents = False

Dim sh As Worksheet
Dim myCol As Long
Dim ffr As Long     'Filtered First Row
Dim flr As Integer     'Filtered Last Row
Dim lr As Long
Dim lr2 As Long
Dim myFilter As String
Dim lr3 As Long
Dim lr4 As Long
Dim chfr As Long     'Chart First Row

  Set sh = ActiveSheet     'Master table worksheet
  myCol = ActiveCell.Column
  lr = sh.Range("A" & Rows.Count).End(4).Row     'does this line define the block of data from row (4) to the last row in column A? 
  myFilter = sh.Range("B" & ActiveCell.Row).Value


  With Sheets("Combo Gantt Chart")
    'Data Transfer
    If sh.AutoFilterMode Then sh.AutoFilterMode = False
    If .AutoFilterMode Then .AutoFilterMode = False
    lr2 = .Range("A" & Rows.Count).End(3).Row + 1
    lr4 = .Range("A" & Rows.Count).End(3).Row + 2

'   STEP 4: Apply Filter for non blank rows

    sh.Range("A2", Cells(lr, myCol)).AutoFilter myCol, "<>"  'Filter out blank rows (but does not do it based on the first column in the block of 6 columns)

'   STEP 1: Apply Filter for rows based on the group number

    sh.Range("A2", Cells(lr, myCol)).AutoFilter field:=2, Criteria1:=myFilter, Operator:=xlFilterValues     'Filter is based on the number in column 2 "group" based on the row selected.
    ffr = sh.Range("A2").End(xlDown).Row
    chfr = Sheet9.Range("A2").End(xlDown).Row     'Sheet9 is my chart page

'    STEP 2: not defined by code yet
'    STEP 3: not defined by code yet

'    STEP 5: Transfer the list of job numbers

'   Copy column A job numbers from Master table and paste them into Column A on the Chart worksheet
    sh.AutoFilter.Range.Offset(1).Columns(1).Copy

'   If Sheets("Chart").range("A3").value = "" Then
'       .Range("A" & lr2).PasteSpecial xlPasteValues
'  Else
'       .Range("A" & lr4).PasteSpecial xlPasteValues
'   End if

    .Range("A" & lr2).PasteSpecial xlPasteValues
    Application.CutCopyMode = False


'    STEP 7: Transfer Data title to Chart Worksheet

'    Add Data Title to row H of Chart worksheet
'    This block of code is based on the myCol reference, but this was set up when transferring only one block of six columns. This block of code DOES NOT factor in shifting blocks of data on each loop.
'    If Sheets("Chart").range("H3").value = "" Then
'       Sheet9.Range("H3").Value = sh.Cells(1, myCol).Value
'   Else
'       Sheet9.Range("H" & lr4).value = sh.Cells(1, myCol).Value
'   End if
    
'   Fill the current cell down to the last filled row of data. This FillDown does not work in my current set up. I do not know why.
    Sheet9.Range("H" & Rows.Count).End(xlUp).FillDown


'    STEP 8: Transfer Data blocks to Chart Worksheet
'   For each column block labeled "YES" in row 2, Transfer the data to the Chart worksheet
    
'   Copy six columns of data from Master and paste into columns B-G on the Chart worksheet
    sh.AutoFilter.Range.Offset(1).Columns(myCol).Resize(, 6).Copy
    .Range("B" & lr2).PasteSpecial xlPasteValues

'   If Sheets("Chart").range("A3").value = "" Then
'       .Range("B" & lr2).PasteSpecial xlPasteValues
'  Else
'       .Range("B" & lr4).PasteSpecial xlPasteValues
'   End if

'    Go to next block of six columns
'    Start LOOP here

    sh.ShowAllData
    sh.AutoFilterMode = False
    .AutoFilterMode = False
  End With

    Application.EnableEvents = True
    Application.ScreenUpdating = True

End Sub

I hope I have been clear enough about what I am trying to do. I hope the tables included below also help in understanding what I am trying to achieve.

Thanks so much for looking this over and helping me create a straightforward and hopefully more simplified code to achieve this data transfer.

Master Data Table:

Book2
	A	B	C	D	E	F	G	H	I	J	K	L	M	N	O	P	Q	R	S	T	U	V	W	X	Y	Z	AA	AB	AC
1	Job	Group	Comp	Rev	Reason	Data title 1	Data title 2	Data title 3	Data title 4	Data title 5	Data title 6	Data title 7	Data title 8	Data title 9	Data title 10	Data title 11	Data title 12	Data title 13	Data title 14	Data title 15	Data title 16	Data title 17	Data title 18	Data title 19	Data title 20	Data title 21	Data title 22	Data title 23	Data title 24
2								YES							YES								YES
3
4
5	111	2	blue	A				1	2	3	4	5	6		6	5	4	3	2	1			7	7	4	4	1	1
6	222	3	pink	B	change 1			2	4	2	5	5	7		9	8	7	6	5	4			8	8	5	5	2	2
7	333	2	green	A				3	3	5	7	7	9		3	2	1	1	2	3			9	9	6	6	3	3
8	444	1	yellow	C	change 2			4	6	4	6	4	6		1	2	3	3	2	1			1	1	5	5	9	9
9	555	4	red	B	change 1			5	5	8	8	2	2		4	4	5	5	6	6			3	3	5	5	7	7
10	666	3	brown	A				7	8	9	9	8	7		6	6	5	5	4	4			2	6	8	4	2	8
11	777	1	gray	D	change 3			8	5	2	5	8	5		1	1	4	4	7	7			1	5	9	7	5	3
12	888	4	orange	C	change 2			7	7	5	5	3	3		2	2	5	5	8	8			8	2	4	6	5	5
13	999	2	purple	B	change 1			9	9	8	8	7	7		3	3	6	6	9	9			1	7	9	3	5	5
Master

Chart Data Table:

Gantt Dummy Table.xlsx
	A	B	C	D	E	F	G	H
1
2	Job	Data 1	Data 2	Data 3	Data 4	Data 5	Data 6	Title
3	111	1	2	3	4	5	6	Data title 3
4	333	3	3	5	7	7	9	Data title 3
5	999	9	9	8	8	7	7	Data title 3
6
7	111	6	5	4	3	2	1	Data title 10
8	333	3	2	1	1	2	3	Data title 10
9	999	3	3	6	6	9	9	Data title 10
10
11	111	7	7	4	4	1	1	Data title 18
12	333	9	9	6	6	3	3	Data title 18
13	999	1	7	9	3	5	5	Data title 18
14
15
16
Chart

 

[DanteAmor]

Try this

Sub Data_Transfer()
  Dim sh As Worksheet, myFilter As Variant, a As Variant, b As Variant, c As Variant
  Dim lc As Long, i As Long, j As Long, f As Long, k As Long, n As Long
  '
  Set sh = Sheets("Master")
  myFilter = sh.Range("B" & ActiveCell.Row).Value
  lc = sh.Cells(1, Columns.Count).End(1).Column
  a = sh.Range("A1", sh.Cells(sh.Range("A" & Rows.Count).End(3).Row, lc)).Value2
  ReDim b(1 To UBound(a, 1) * Int(lc / 6), 1 To 8)
  ReDim c(1 To UBound(a, 1), 1 To 1)
  '
  For i = 1 To UBound(a, 1)
    If a(i, 2) = myFilter Then
      f = f + 1
      c(f, 1) = i
    End If
  Next i
  '
  For j = 6 To UBound(a, 2)
    If a(2, j) = "YES" Then
      For i = 1 To f
        n = n + 1
        b(n, 1) = a(c(i, 1), 1)
        b(n, 8) = a(1, j)
        For k = 0 To 5
          b(n, k + 2) = a(c(i, 1), j + k)
        Next k
      Next i
      j = j + 5
      n = n + 1
    End If
  Next j
  Sheets("Chart").Range("A" & Rows.Count).End(3)(2).Resize(n, 8).Value = b
End Sub

 

[rjplante]

This macro works slick, but I need help with a couple of modifications. First, I want the macro to filter the data by column B, group number, and then filter out all the blank rows for the first column with a YES is row 2. The macro currently filters out for the group number, but does not filter out the blank rows (Step 4 in my list above). How do I get it to filter out the blank rows?

 

[DanteAmor]

Hi, What do you mean by blank rows. in your example there are no blank rows. You can put examples where I see blank rows and the expected result.

 

[rjplante]

My Apologies, you are correct. I did not have any blank rows in my data table above. I have updated the table and the chart. Please review and advise accordingly.

Updated Master Table:

Gantt Dummy Table.xlsx
	A	B	C	D	E	F	G	H	I	J	K	L	M	N	O	P	Q	R	S	T	U	V	W	X	Y	Z	AA	AB	AC
1	Job	Group	Comp	Rev	Reason	Data title 1	Data title 2	Data title 3	Data title 4	Data title 5	Data title 6	Data title 7	Data title 8	Data title 9	Data title 10	Data title 11	Data title 12	Data title 13	Data title 14	Data title 15	Data title 16	Data title 17	Data title 18	Data title 19	Data title 20	Data title 21	Data title 22	Data title 23	Data title 24
2								YES							YES								YES
3
4
5	111	2	blue	A
6	222	3	pink	B	change 1			2	4	2	5	5	7		9	8	7	6	5	4			8	8	5	5	2	2
7	333	2	green	A				3	3	5	7	7	9		3	2	1	1	2	3			9	9	6	6	3	3
8	444	1	yellow	C	change 2			4	6	4	6	4	6		1	2	3	3	2	1			1	1	5	5	9	9
9	555	2	red	B	change 1			5	5	8	8	2	2		4	4	5	5	6	6			3	3	5	5	7	7
10	666	3	brown	A				7	8	9	9	8	7		6	6	5	5	4	4			2	6	8	4	2	8
11	777	2	gray	D	change 3
12	888	4	orange	C	change 2			7	7	5	5	3	3		2	2	5	5	8	8			8	2	4	6	5	5
13	999	2	purple	B	change 1			9	9	8	8	7	7		3	3	6	6	9	9			1	7	9	3	5	5
Master

Updated Chart:

Gantt Dummy Table.xlsx
	A	B	C	D	E	F	G	H
2	Job	Data 1	Data 2	Data 3	Data 4	Data 5	Data 6	Title
3	333	3	3	5	7	7	9	Data title 3
4	555	5	5	8	8	2	2	Data title 3
5	999	9	9	8	8	7	7	Data title 3
6
7	333	3	2	1	1	2	3	Data title 10
8	555	4	4	5	5	6	6	Data title 10
9	999	3	3	6	6	9	9	Data title 10
10
11	333	9	9	6	6	3	3	Data title 18
12	555	3	3	5	5	7	7	Data title 18
13	999	1	7	9	3	5	5	Data title 18
14
15
16
Chart

Thanks

 

[DanteAmor]

but does not filter out the blank rows

Try this

Sub Data_Transfer()
  Dim sh As Worksheet, myFilter As Variant, a As Variant, b As Variant, c As Variant
  Dim lc As Long, i As Long, j As Long, f As Long, k As Long, n As Long, dats As Boolean
  '
  Set sh = Sheets("Master")
  myFilter = sh.Range("B" & ActiveCell.Row).Value
  lc = sh.Cells(1, Columns.Count).End(1).Column
  a = sh.Range("A1", sh.Cells(sh.Range("A" & Rows.Count).End(3).Row, lc)).Value2
  ReDim b(1 To UBound(a, 1) * Int(lc / 6), 1 To 8)
  ReDim c(1 To UBound(a, 1), 1 To 1)
  '
  For i = 1 To UBound(a, 1)
    If a(i, 2) = myFilter Then
      dats = False
      For j = 6 To UBound(a, 2)
        If a(i, j) <> "" Then
          dats = True
          Exit For
        End If
      Next
      If dats = True Then
        f = f + 1
        c(f, 1) = i
      End If
    End If
  Next i
  '
  For j = 6 To UBound(a, 2)
    If a(2, j) = "YES" Then
      For i = 1 To f
        n = n + 1
        b(n, 1) = a(c(i, 1), 1)
        b(n, 8) = a(1, j)
        For k = 0 To 5
          b(n, k + 2) = a(c(i, 1), j + k)
        Next k
      Next i
      j = j + 5
      n = n + 1
    End If
  Next j
  Sheets("Chart").Range("A" & Rows.Count).End(3)(2).Resize(n, 8).Value = b
End Sub

 

[rjplante]

Wow that is some pretty cool code. It works great. I wish I was smart enough to understand what it is doing, and what your code means, but I will have to content myself with the simple fact that it is working wonderfully.