跨多個工作表運行 VBA 代碼問題

Question

我目前正在使用此代碼，它通過我的工作表並檢查范圍 O15:O300 以查看是否有任何與當前日期匹配的單元格。 如果有，則將整行復制到工作表“今日行動”，然后將站點編號（位於單元格 C3 中）復制到“今日行動”中的 AA 列。

我使用以下代碼，該代碼適用於一張特定工作表的此任務：

Sub rangecheck()

Application.ScreenUpdating = False

For Each cell In Range("O15:O300")

    If cell.Value = Date Then
        matchRow = cell.Row
        Rows(matchRow & ":" & matchRow).Select
        Selection.Copy
        Sheets("Today's Actions").Range("A" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
        ActiveSheet.Range("C3").Copy
        Sheets("Today's Actions").Range("AA" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
    End If
Next

Application.ScreenUpdating = True


End Sub

但是，我需要對多張工作表執行此代碼。 所以我使用下面的代碼在所有工作表上運行它：

Sub rangecheck_Set()

Dim ws As Worksheet

Dim starting_ws As Worksheet

Set starting_ws = ActiveSheet 

Application.ScreenUpdating = False

For Each ws In ThisWorkbook.Worksheets

    ws.Activate

    Call rangecheck
    
Next

starting_ws.Activate 'activate the worksheet that was originally active ("Today's Actions")

Application.ScreenUpdating = True

End Sub

我遇到的這個問題是它似乎可以正常工作，但是只要在 O15:O300 范圍內有很多日期與今天的日期匹配時，它就會隨機復制一些行，最多或略超過 300 行（例如，如果有 15 行“應該”被帶回“今天的行動”選項卡，它會將它們帶回來，但隨后將其他幾行隨機復制到第 300 行左右）。

我知道這可能是由於范圍下降到 300，但我什至編輯了范圍以轉到“最后一行”，它仍然帶來了同樣的問題。 有什么想法嗎？ 這幾天我一直在努力解決這個問題。 任何幫助表示贊賞

Answer 1

不要使用對工作表和范圍的隱式引用。 這很可能是您的問題的原因。

此外，您無需選擇和復制 - 不可預見錯誤的另一個來源。

您的錯誤的另一個原因可能是您沒有從復制程序中排除“今日行動”表。

我重寫了復制數據的子程序：

Sub copyTodaysRows(wsSource As Worksheet, wsTarget As Worksheet)

If wsSource is wsTarget then Exit Sub   'don't run this for the target sheet

Dim c As Range, wsTargetNewRow As Long

For Each c In wsSource.Range("O15:O300")

    If c.Value = Date Then
        With wsTarget
            wsTargetNewRow = .Range("A" & .Rows.Count).End(xlUp).Row + 1
            c.EntireRow.Copy Destination:=.Range("A" & wsTargetNewRow) 
            .Range("AA" & wsTargetNewRow).Value = wsSource.Range("C3").Value
        End With
    End If
Next



End Sub

它將源工作表和目標工作表作為輸入參數。

您將在“外部”例程中這樣稱呼它：

Sub rangecheck_Set()


Application.ScreenUpdating = False

Dim wsSource as worksheet

Dim wsTarget as worksheet
Set wsTarget = Thisworkbook.Worksheets("Today's Actions")

For Each wsSource In ThisWorkbook.Worksheets
   copyTodaysRows wsSource, wsTarget
Next
Application.ScreenUpdating = True

End Sub

Answer 2

從多個工作表中復制條件（日期）行的值

Option Explicit

Sub RetrieveTodaysActions()
    ' Calls 'RetrieveTodaysActionsCall'.
    
    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    
    Dim sws As Worksheet
    
    For Each sws In ThisWorkbook.Worksheets
        RetrieveTodaysActionsCall sws
    Next sws

    MsgBox "Today's actions retrieved.", vbInformation

End Sub

Sub RetrieveTodaysActionsCall(ByVal sws As Worksheet)
    
    ' Define constants.
    ' Source
    Const sCriteriaColumnAddress As String = "O15:O300"
    Const sCol1 As String = "A"
    Const sCell2Address As String = "C3"
    ' Destination
    Const dName As String = "Today's Actions"
    Const dCol1 As String = "A"
    Const dCol2 As String = "AA"
    ' Both
    ' Write the criteria date to a variable ('CriteriaDate').
    Dim CriteriaDate As Date: CriteriaDate = Date ' today
    
    ' Exclude the destination worksheet.
    If StrComp(sws.Name, dName, vbTextCompare) = 0 Then Exit Sub
    
    ' Reference the source criteria column range ('scrg').
    Dim scrg As Range: Set scrg = sws.Range(sCriteriaColumnAddress)
    
    ' Check the number of matches, the number of rows to be copied
    ' to the destination worksheet.
    If Application.CountIf(scrg, Date) = 0 Then Exit Sub
    
    ' Reference the range ('surg'), the range from the first cell
    ' in the source column ('sCol1') to the last cell of the used range.
    Dim surg As Range
    With sws.UsedRange
        Set surg = sws.Range(sCol1 & 1, .Cells(.Rows.Count, .Columns.Count))
    End With
    
    ' Reference the source range ('srg').
    Dim srg As Range: Set srg = Intersect(scrg.EntireRow, surg)
    If srg Is Nothing Then Exit Sub
    
    ' Write the number of columns of the source range to a variable (cCount).
    Dim cCount As Long: cCount = srg.Columns.Count
    
    ' Write the criteria column number to a variable ('CriteriaColumn').
    Dim CriteriaColumn As Long: CriteriaColumn = scrg.Column
    
    ' Write the values from the source range to an array ('Data').
    Dim Data() As Variant: Data = srg.Value
        
    Dim sValue As Variant ' Criteria Value in the Current Source Row
    Dim sr As Long ' Current Source Row
    Dim c As Long ' Current Source/Destination Column
    Dim dr As Long ' Current Destination Row
    
    ' Loop through the rows of the array.
    For sr = 1 To UBound(Data, 1)
        ' Write the value in the current row to a variable.
        sValue = Data(sr, CriteriaColumn)
        ' Check if the current value is a date.
        If IsDate(sValue) Then
            ' Check if the current value is equal to the criteria date.
            If sValue = CriteriaDate Then
                dr = dr + 1
                ' Write the values from the source row to the destination row.
                For c = 1 To cCount
                    Data(dr, c) = Data(sr, c)
                Next c
            End If
        End If
    Next sr
    
    ' Reference the destination worksheet ('dws').
    Dim dws As Worksheet: Set dws = sws.Parent.Worksheets(dName)
    
    ' Reference the destination first cell ('dfCell').
    Dim dfCell As Range
    Set dfCell = dws.Cells(dws.Rows.Count, dCol1).End(xlUp).Offset(1)
    
    ' Reference the destination range ('drg').
    Dim drg As Range: Set drg = dfCell.Resize(dr, cCount)
    
    ' Write the values from the array to the destination range.
    drg.Value = Data
    
    ' Reference the destination range 2 ('drg2').
    Dim drg2 As Range: Set drg2 = drg.EntireRow.Columns(dCol2)
    
    ' Write the source cell 2 value to the destination range 2 ('drg2')
    ' (the same value to all cells of the range).
    drg2.Value = sws.Range(sCell2Address).Value
    
End Sub

Answer 3

我的過程與其他回復不同，所以我仍然會發布它。 我還添加了一種記錄已記錄行的方法，因為否則我看到行可以復制到“今天的操作”表中。

Sub rangecheck(ByVal checkedSheet As Worksheet)
'@PARAM checkedSheet is the sheet to iterate through for like dates.

'Instantiate counter variables
Dim matchRow As Integer
    matchRow = 0
Dim pasteRow As Integer
    pasteRow = 0

Application.ScreenUpdating = False

For Each cell In checkedSheet.Range("O15:O300")

    If cell.Value = Date Then
        matchRow = cell.Row
        'Checks if the row has been logged already (I use column "A" because I 
        'have no data in it, but this can be amy column in the row)
        If checkedSheet.Cells(matchRow, 1) = "Logged" Then
        'Do nothing
        Else
            'Sets value of "pasteRow" to one lower than the lowest used row in 
column "AA"
            pasteRow = Sheets("Today's Actions").Cells(Rows.Count, 
27).End(xlUp).Row + 1
        
            'Copies the values of the matchRow to the pasteRow
            Sheets("Today's Actions").Rows(pasteRow).Value = 
checkedSheet.Rows(matchRow).Value
        
            'Copies the value of the Site Number to the paste row column "AA"
            Sheets("Today's Actions").Cells(pasteRow, 27).Value = 
checkedSheet.Cells(3, 3).Value
        
            'Log that a row has been added to the "Today's Actions" sheet
            checkedSheet.Cells(matchRow, 1) = "Logged"
        
        End If
    End If
Next

Application.ScreenUpdating = True

End Sub

我還修改了您的子程序，它調用復制子程序來檢查它是否試圖復制“今日行動”表。

Sub rangecheck_Set()

Dim ws As Worksheet

Dim starting_ws As Worksheet

Set starting_ws = Worksheets("Today's Actions")

Application.ScreenUpdating = False

For Each ws In ThisWorkbook.Worksheets

    'Check if the ws to check is "Today's Actions"
    If ws.Name = "Today's Actions" Then
    'Do Nothing
    Else
        Call rangecheck(ws)
    End If

Next

starting_ws.Activate 'activate the worksheet that was originally active 

Application.ScreenUpdating = True

End Sub