Question

我想迭代多张纸（33 omg），在每张纸上迭代A列，范围为A1-A260并查看单元格是否为空。如果它不为空，请将其复制到工作表“摘要”中A列中的下一个空单元格。我写的是代码。

Sub WorksheetLoop()

  Dim WS_Count As Integer
  Dim I As Integer
  Dim sheetName As String

  WS_Count = ActiveWorkbook.Worksheets.Count - 1

  For I = 1 To WS_Count
     sheetName = ActiveWorkbook.Worksheets(I).Name

 Dim rng As Range
 Dim row As Range
 Dim cell As Range

 Set rng = Range("A1:A260")

 For Each row In rng.Rows
   For Each cell In row.Cells
      If cell.Value = vbNullString Then
        cell.Copy
        Worksheets("Summary").Range("A2").End(xlUp).PasteSpecial xlPasteValues

      End If

   Next cell
 Next row

Next I

End Sub

但每次我运行此代码时，它似乎都是无穷大（或接近无穷大的东西），因为excel没有响应。你有什么建议改变？ ps我是非常大的noob @ vba编程，欢迎任何解释:)

Answer 1

执行此类任务的最有效方法是将所有数据加载到数组中，然后在数组而不是Excel单元格上运行。

以下是使用数组的任务代码（我添加了一些注释，因此您应该知道发生了什么）：

Sub WorksheetLoop()
    Dim wkb As Excel.Workbook
    Dim wks As Excel.Worksheet
    Dim data As Variant
    Dim row As Long
    Dim cellValue As Variant
    Dim nonEmptyCells() As Variant
    Dim firstEmptyRow As Long
    Dim destinationRange As Excel.Range
    '------------------------------------------------------------


    Set wkb = Excel.ActiveWorkbook


    'Iterate through all the worksheets, search through theirs first column
    'and collect data from all non-empty cells into a separate String array
    'nonEmptyCells().
    For Each wks In wkb.Worksheets

        If wks.Name <> "Summary" Then

            With wks

                Debug.Print wks.Name

                'Read data into array and use this array to operate on those
                'data later instead of operating directly on Excel cells -
                'it will improve performance.
                data = .Range(.Cells(1, 1), .Cells(260, 1))


                'Iterate through all the values read from the currently
                'processed worksheet.
                For row = LBound(data, 1) To UBound(data, 1)

                    'Assign value from array to variable for better readability.
                    cellValue = data(row, 1)

                    'If this value is not empty, add it to array nonEmptyCells.
                    If cellValue <> vbNullString Then
                        Call addEntry(nonEmptyCells, cellValue)
                    End If

                Next row


            End With

        End If

    Next wks



    'At this point all the values from non-empty cells from all worksheets
    'are collected in array nonEmptyCells. All we have to do is to paste
    'them to worksheet "Summary"


    'Check if there are any values in nonEmptyCells. If not, there is nothing
    'to be printed out in "Summary" worksheet and we can leave the macro.
    If countDimensions(nonEmptyCells) = 0 Then Exit Sub



    'Find first empty row in worksheet "Summary".
    Set wks = wkb.Worksheets("Summary")
    firstEmptyRow = wks.Cells(wks.Rows.Count, 1).End(xlUp).row + 1


    Set destinationRange = wks.Cells(firstEmptyRow, 1).Resize(UBound(nonEmptyCells) - LBound(nonEmptyCells), 1)
    destinationRange = Application.WorksheetFunction.Transpose(nonEmptyCells)



End Sub

请注意，要使此宏正常工作，您需要将此功能粘贴到代码中：function for adding new entry to dynamic array。

Answer 2

您可以简单地遍历单元格并使用.value属性

  Dim WS As Worksheet
  r = 0
  For Each WS In ActiveWorkbook.Worksheets
    If Not WS.Name = "Summary" Then
     For I = 1 To 260
       v = WS.Range("A" & I).Value
       If Not v = vbNullString Then
         r = r + 1
         Worksheets("Summary").Range("A" & r) = v
       End If
     Next I
    End If
  Next WS

Answer 3

如果您只想添加非空单元格，则需要将“= vbnullstring”更改为“＆lt;＆gt; vbnullstring”，如果不是摘要，您可能只想检查非空值片。我还注意到你总是在摘要表中将新行添加到单元格A2，基本上消除了之前添加的内容。这应解决所有这些问题，同时仍保留大部分原始代码。

Sub WorksheetLoop()

    Dim WS_Count As Integer
    Dim I As Integer
    Dim sheetName As String
    Dim rng As Range
    Dim row As Range
    Dim cell As Range
    Dim rw as long

    WS_Count = ActiveWorkbook.Worksheets.Count - 1
    rw = 1

    For I = 1 To WS_Count
        sheetName = ActiveWorkbook.Worksheets(I).Name

        If sheetName <> "Summary" Then
            Set rng = Sheets(sheetName).Range("A1:A260")

            For Each row In rng.Rows
                For Each cell In row.Cells

                    If cell.Value <> vbNullString Then
                        cell.Copy

                        Worksheets("Summary").Range("A" & rw).PasteSpecial Paste:=xlPasteValues
                        rw = rw + 1

                    End If

                Next cell
            Next row

        End If
    Next I

End Sub

迭代excel工作表并复制非空单元格值

3 个答案: