遍歷excel工作表並複製非空單元格值

Question

我想循環遍歷許多工作表（33 omg），在每個工作表上遍歷範圍爲A1-A260的列A並查看單元格是否爲空。如果不爲空，則將其複製到A列中「Summary」表中的下一個空單元格。有我寫的代碼。

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

你可以簡單地遍歷細胞和使用.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 2

執行此類任務的最有效方法是將所有數據加載到數組中，並對數組而不是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 3

如果你只是想添加非空白單元格，你會想改變「= vbnullstring」到「<> 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