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

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

1 个答案: