Data table transfer loop

rjplante

Well-known Member
Joined
Oct 31, 2008
Messages
503
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:
VBA Code:
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
ABCDEFGHIJKLMNOPQRSTUVWXYZAAABAC
1JobGroupCompRevReasonData title 1Data title 2Data title 3Data title 4Data title 5Data title 6Data title 7Data title 8Data title 9Data title 10Data title 11Data title 12Data title 13Data title 14Data title 15Data title 16Data title 17Data title 18Data title 19Data title 20Data title 21Data title 22Data title 23Data title 24
2YESYESYES
3
4
51112blueA123456654321774411
62223pinkBchange 1242557987654885522
73332greenA335779321123996633
84441yellowCchange 2464646123321115599
95554redBchange 1558822445566335577
106663brownA789987665544268428
117771grayDchange 3852585114477159753
128884orangeCchange 2775533225588824655
139992purpleBchange 1998877336699179355
Master



Chart Data Table:
Gantt Dummy Table.xlsx
ABCDEFGH
1
2JobData 1Data 2Data 3Data 4Data 5Data 6Title
3111123456Data title 3
4333335779Data title 3
5999998877Data title 3
6
7111654321Data title 10
8333321123Data title 10
9999336699Data title 10
10
11111774411Data title 18
12333996633Data title 18
13999179355Data title 18
14
15
16
Chart
 

Excel Facts

What do {} around a formula in the formula bar mean?
{Formula} means the formula was entered using Ctrl+Shift+Enter signifying an old-style array formula.

DanteAmor

Well-known Member
Joined
Dec 3, 2018
Messages
12,620
Office Version
  1. 2007
Platform
  1. Windows
Try this

VBA Code:
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

Well-known Member
Joined
Oct 31, 2008
Messages
503
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

Well-known Member
Joined
Dec 3, 2018
Messages
12,620
Office Version
  1. 2007
Platform
  1. Windows
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

Well-known Member
Joined
Oct 31, 2008
Messages
503

ADVERTISEMENT

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
ABCDEFGHIJKLMNOPQRSTUVWXYZAAABAC
1JobGroupCompRevReasonData title 1Data title 2Data title 3Data title 4Data title 5Data title 6Data title 7Data title 8Data title 9Data title 10Data title 11Data title 12Data title 13Data title 14Data title 15Data title 16Data title 17Data title 18Data title 19Data title 20Data title 21Data title 22Data title 23Data title 24
2YESYESYES
3
4
51112blueA
62223pinkBchange 1242557987654885522
73332greenA335779321123996633
84441yellowCchange 2464646123321115599
95552redBchange 1558822445566335577
106663brownA789987665544268428
117772grayDchange 3
128884orangeCchange 2775533225588824655
139992purpleBchange 1998877336699179355
Master


Updated Chart:

Gantt Dummy Table.xlsx
ABCDEFGH
2JobData 1Data 2Data 3Data 4Data 5Data 6Title
3333335779Data title 3
4555558822Data title 3
5999998877Data title 3
6
7333321123Data title 10
8555445566Data title 10
9999336699Data title 10
10
11333996633Data title 18
12555335577Data title 18
13999179355Data title 18
14
15
16
Chart


Thanks
 

DanteAmor

Well-known Member
Joined
Dec 3, 2018
Messages
12,620
Office Version
  1. 2007
Platform
  1. Windows
but does not filter out the blank rows
Try this

VBA Code:
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

Well-known Member
Joined
Oct 31, 2008
Messages
503
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.
 

Watch MrExcel Video

Forum statistics

Threads
1,129,678
Messages
5,637,741
Members
416,982
Latest member
lisam77

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top