VBA - 我需要在一行中循环多个范围的列，然后为每个新行重复

Question

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

对于 VBA 来说相对较新，并且在沿行的列（名称到国家/地区）循环多个范围然后对下一行（下一个名称）执行相同操作时遇到问题。这是针对 A 列中未知数量的名称。

我似乎找不到任何与我的问题相关的东西。

这个想法是需要遍历黄色类别，并且对于子类别中的每个“是”，然后将子标题即 1a.coms 打印在新工作表中的一列下（1.data cat 的新列，2 .type 和 3.com）。然后，一旦知道三个主要类别中最长的子类别列表，具有蓝色列标题的类别将被粘贴到相邻列的次数与最长列表相同。

我目前正在考虑是否可以使用 vba？ 我正在努力解决的是在单独的范围内运行循环以及为每个新名称再次循环，试图使其在每个范围的每一行中工作，然后向下移动到下一列并重复......

我的代码有点乱，因为我一直在尝试新事物，但无济于事..

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

Answer 1

下面将使用第二张工作表来显示摘要，它并不完全存在，因为它会为每个需要添加的项目添加一个新行，但稍作改动，你应该可以做到做你所期望的，如果没有别的，它应该为你指明正确的方向：

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