CODEWITHSUNDEEP
vbaexcel
Myles Stenlake
Myles Stenlake

Reputation: 1

VBA - I need to Loop across columns for mutiple ranges along a row then repeat for each new row

I am trying to go from the top table to the bottom table

Relatively new to VBA and having issues with looping over mutiple ranges along the columns (Name to country) of a row then doing the same for the next row (the next name). This is for an unknown amount of names in column A.

I just Can't seem to find anything that's near my problem.

The idea is that need to run through the yellow catagories, and for each yes in the subcatagories is to then print the subheading i.e 1a.coms in a new sheet down a column (a new column for 1.data cat, 2.type and 3.com). Then once the longest list of sub catagories out of the three main catagories is known, the catagories with the blue column headers are pasted down adjacent columns as many times as the longest list.

I'm currently thinking if it's even possible with vba? What i'm struggling with is running loops over the seperate ranges as well as looping over again for each new name, trying to make it work across each row for each range then move to the next column down and repeat...

My code is a bit of a mess as I keep trying new things to no availe.. 

UpdateNew()

Dim dsheet As Worksheet
Dim rptsheet As Worksheet
Dim lastrow As Integer
Dim lastcol As Integer
Set dsheet = ThisWorkbook.Sheets("sheet2")
Set rptsheet = ThisWorkbook.Sheets("myRpt")



  ' Set the totals range
Dim rowStart As Long, rowEnd As Long
Dim colStart As Long, colEnd As Long
Dim colStartj As Long, colendj As Long
Dim colStartjj As Long, colendjj As Long
Dim colStartjjj As Long, colendjjj As Long


rowStart = 3
'rowStartii = 4
'rowStartiii = 4
lastrow = dsheet.Cells(Rows.Count, 1).End(xlUp).Row
colStartj = 5
 colStartjj = 10
  colStartjjj = 16

colendj = 9
 colendjj = 15
  colendjjj = 19

colrptj = 5
 colrptjj = 6
  colrptjjj = 7

str_r_rptj = 2
end_r_rptj = 6


' Set the values row
'Dim rowValues As Long
'rowValues = 11

Dim colCnt As Long

'Dim i As Long, j As Long
'Dim ii As Long, jj As Long
'Dim iii As Long, jjj As Long
' Read through the rows
For i = rowstarti To lastrow

    ' Reset value column to 1
    'colCnt = 1
    ' Read through the columns for the current row
    For j = colStartj To colendj
     'del = rptsheet.Columns(colrptj).SpecialCells(xlBlanks).Rows.Delete


       If dsheet.Cells(rowStart, j) = dsheet.Cells(3, 5) Then
       rptsheet.Cells(str_r_rpti + i, colrptj) = dsheet.Cells(2, j)

    If Not dsheet.Cells(rowStart, j) <> dsheet.Cells(3, 5) Then
     rptsheet.Cells(str_r_rpti + i, colrptj).ClearContents




        ' Move value column on 1
        'colCnt = colCnt + 1

          End If
         End If


  Next j
  j = j + 1

  Next i
  i = i + 1


  'For jj = colStartjj To colendjj
   ' For jjj = colStartjjj To colendjjj
  'If dsheet.Cells(rowStart, jj) = "yes" Then
   '    rptsheet.Cells(str_r_rpti + i, colrptjj) = dsheet.Cells(2, jj)

    '   If dsheet.Cells(rowStart, jjj) = "yes" Then
     '  rptsheet.Cells(str_r_rpti + i, colrptjjj) = dsheet.Cells(2, jjj)

      ' Next jjj
  ' Next jj


End Sub

Upvotes: 0

Views: 74

Answers (1)

Xabier
Xabier

Reputation: 7735

The following will use a second Sheet to display the summary, it isn't quite there, as it will add a new row per item that needs to be added, but with a little alteration, you should be able to make it do what you expect, if nothing else it should point you in the right direction:

Sub foo()
Dim ws As Worksheet: Set ws = Sheets("Sheet1")
Dim wsSummary As Worksheet: Set wsSummary = Sheets("Sheet2")
'declare and set your worksheets above, amend as required

LastRow = ws.Cells(ws.Rows.Count, "S").End(xlUp).Row
'get the last row with data from Sheet1 Column S
For i = 3 To LastRow
    For x = 5 To 9
        If ws.Cells(i, x) = "yes" Then
            SummaryNextRow = wsSummary.Cells(wsSummary.Rows.Count, "A").End(xlUp).Row + 1
            wsSummary.Cells(SummaryNextRow, 5) = ws.Cells(2, x)
            wsSummary.Cells(SummaryNextRow, 8) = ws.Cells(i, 19)
            wsSummary.Cells(SummaryNextRow, 1) = ws.Cells(i, 1)
            wsSummary.Cells(SummaryNextRow, 2) = ws.Cells(i, 2)
            wsSummary.Cells(SummaryNextRow, 3) = ws.Cells(i, 3)
            wsSummary.Cells(SummaryNextRow, 4) = ws.Cells(i, 4)
            Counter = Counter + 1
        End If
    Next x

    For x = 10 To 15

        If ws.Cells(i, x) = "yes" Then
            SummaryNextRow = wsSummary.Cells(wsSummary.Rows.Count, "A").End(xlUp).Row + 1
            wsSummary.Cells(SummaryNextRow, 6) = ws.Cells(2, x)
            wsSummary.Cells(SummaryNextRow, 8) = ws.Cells(i, 19)
            wsSummary.Cells(SummaryNextRow, 1) = ws.Cells(i, 1)
            wsSummary.Cells(SummaryNextRow, 2) = ws.Cells(i, 2)
            wsSummary.Cells(SummaryNextRow, 3) = ws.Cells(i, 3)
            wsSummary.Cells(SummaryNextRow, 4) = ws.Cells(i, 4)
        End If
    Next x

    For x = 16 To 18
        If ws.Cells(i, x) = "yes" Then
            SummaryNextRow = wsSummary.Cells(wsSummary.Rows.Count, "A").End(xlUp).Row + 1
            wsSummary.Cells(SummaryNextRow, 7) = ws.Cells(2, x)
            wsSummary.Cells(SummaryNextRow, 8) = ws.Cells(i, 19)
            wsSummary.Cells(SummaryNextRow, 1) = ws.Cells(i, 1)
            wsSummary.Cells(SummaryNextRow, 2) = ws.Cells(i, 2)
            wsSummary.Cells(SummaryNextRow, 3) = ws.Cells(i, 3)
            wsSummary.Cells(SummaryNextRow, 4) = ws.Cells(i, 4)
        End If
    Next x
Next i
End Sub

Upvotes: 0

Related Questions