正如您在影像中看到的，L、M、W:Z 列中有一些空單元格。我正在嘗試遍歷作業簿中的所有作業表。從 Sheet1 開始，過濾掉“A7”中藍色標題下的空“L”單元格，復制值陣列（在 A:Z 或所有具有該行值的單元格之間，理想情況下），將復制的陣列粘貼到摘要中作業表，為每張作業表復制 P2 并將值粘貼為作業表之間的分隔符。然后繼續回圈通過床單。通常，這些作業簿有 100-150 張紙——這就是我試圖自動化這個程序的原因。 給幫助者的注意事項：
- 非常感謝您的時間和禮貌！如果你住在落基山脈，讓我給你買杯啤酒。
- 這些作業簿是為作業而生成的，因此我相應地調整了值。
- 南方公園到處都是我用 VBA 的風格，因為沒有人看到或使用它們
- 我是 VBA 的新手，從網路上的各種堆疊溢位中剪切和粘貼以前的專案，以達到我的最終目標。我在這個墻上撞得很厲害，我將不勝感激！到目前為止的問題：行號是動態的，在沒有變化的情況下過濾后，我似乎無法使用行“A7”的偏移量。
Sub Missing_L_Value_Summary()
Dim MyRange As Range
Dim MyCell As Range
Dim ws As Worksheet, myValue
Dim lCount As Long
Dim title As Long
Dim rng As Range
Application.ScreenUpdating = False
Application.EnableEvents = False
ActiveSheet.Name = "Sheet1"
'Workbook.Save.Name = Range("A2") & "James Cameron"
'Range("A2").Copy
Sheets.Add.Name = "Summary"
Sheets("Summary").Select
'Range("A1").PasteSpecial
ActiveCell.Offset(2, 1).Select
Sheets("Sheet1").Select
Range("A8").Copy
Sheets("Summary").Select
ActiveCell.PasteSpecial
Range("B3").EntireColumn.AutoFit
Sheets("Sheet1").Select
Range("$A$7:$Z$7").Copy
Sheets("Summary").Select
ActiveCell.Offset(1, 0).PasteSpecial
Sheets("Sheet1").Select
For Each ws In Sheets
Range("L7").Select
With ws.Cells(7, 12).CurrentRegion
.AutoFilter Field:=12, Criteria1:="="'
Application.ScreenUpdating = True
Application.EnableEvents = True
MsgBox("James Cameron doesn't do what James Cameron does for James Cameron. James Cameron does
End Sub
what James Cameron does for James Cameron!")
uj5u.com熱心網友回復：
獲取過濾的行
Option Explicit
Sub Missing_L_Value_Summary()
Const ProcName As String = "Missing_L_Value_Summary"
On Error GoTo ClearError
Dim IsSuccess As Boolean
Const sExceptionsList As String = "Summary" ' add more
Const sExceptionsDelimiter As String = ","
Const sBeforeSheetName As String = "Sheet1"
Const sfCellAddressCR As String = "L7"
Const sDateAddress As String = "P2"
Const sField As Long = 12
Const sCriteria As String = "="
Const dName As String = "Summary"
Const dfCellAddress As String = "A3"
Const dDateCol As String = "B"
Application.ScreenUpdating = False
Application.EnableEvents = False
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
Dim dws As Worksheet
On Error Resume Next ' prevent error if it doesn't exist
Set dws = wb.Worksheets(dName)
On Error GoTo ClearError
If Not dws Is Nothing Then
Application.DisplayAlerts = False ' delete without confirmation
dws.Delete
Application.DisplayAlerts = True
End If
Set dws = wb.Worksheets.Add(Before:=wb.Worksheets(sBeforeSheetName))
dws.Name = dName
Dim dCell As Range: Set dCell = dws.Range(dfCellAddress)
Dim sExceptions() As String
sExceptions = Split(sExceptionsList, sExceptionsDelimiter)
Dim sws As Worksheet
Dim srg As Range
Dim svrg As Range
Dim drg As Range
Dim dData As Variant
Dim drCount As Long
Dim ErrNum As Long
For Each sws In wb.Worksheets
If IsError(Application.Match(sws.Name, sExceptions, 0)) Then
If sws.AutoFilterMode Then sws.AutoFilterMode = False
' Write date.
dCell.EntireRow.Columns(dDateCol).Value = sws.Range(sDateAddress)
Set dCell = dCell.Offset(1)
' Write data.
Set srg = sws.Range(sfCellAddressCR).CurrentRegion
On Error Resume Next
srg.AutoFilter sField, sCriteria
ErrNum = Err.Number
On Error GoTo ClearError
If ErrNum = 0 Then
On Error Resume Next
Set svrg = srg.SpecialCells(xlCellTypeVisible)
On Error GoTo ClearError
sws.AutoFilterMode = False
If Not svrg Is Nothing Then
dData = GetFilteredRows(svrg)
If Not IsEmpty(dData) Then
drCount = UBound(dData, 1)
Set drg = dCell.Resize(drCount, UBound(dData, 2))
drg.Value = dData
Set dCell = dCell.Offset(drCount)
Set svrg = Nothing
End If
End If
End If
End If
Next sws
IsSuccess = True
SafeExit:
If Application.EnableEvents = False Then
Application.EnableEvents = True
Application.ScreenUpdating = True
End If
If IsSuccess Then
MsgBox "James Cameron doesn't do what James Cameron does " _
& "for James Cameron. James Cameron does what James Cameron does " _
& "for James Cameron!", vbInformation
Else
MsgBox "Something went wrong.", vbCritical
End If
Exit Sub
ClearError:
Debug.Print "'" & ProcName & "': Unexpected Error!" & vbLf _
& " " & "Run-time error '" & Err.Number & "':" & vbLf _
& " " & Err.Description
Resume SafeExit
End Sub
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose: Returns the values of a filtered range in a 2D one-based array.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function GetFilteredRows( _
ByVal FilteredRange As Range) _
As Variant
Const ProcName As String = "GetFilteredRows"
On Error GoTo ClearError
Dim saCount, drCount, cCount
With FilteredRange
saCount = .Areas.Count
drCount = Intersect(.Offset(0), _
.Worksheet.Columns(.Cells(1).Column)).Cells.Count
cCount = .Areas(1).Columns.Count
End With
Dim dData As Variant: ReDim dData(1 To drCount, 1 To cCount)
Dim sarg As Range
Dim sData As Variant
Dim srCount As Long, sr As Long, dr As Long, c As Long
For Each sarg In FilteredRange.Areas
srCount = sarg.Rows.Count
If cCount srCount > 2 Then
sData = sarg.Value
Else
ReDim sData(1 To 1, 1 To 1)
sData(1, 1) = sarg.Value
End If
For sr = 1 To srCount
dr = dr 1
For c = 1 To cCount
dData(dr, c) = sData(sr, c)
Next c
Next sr
Next sarg
GetFilteredRows = dData
ProcExit:
Exit Function
ClearError:
Debug.Print "'" & ProcName & "': Unexpected Error!" & vbLf _
& " " & "Run-time error '" & Err.Number & "':" & vbLf _
& " " & Err.Description
Resume ProcExit
End Function
uj5u.com熱心網友回復：
我只使用偏移公式，因為如果我洗掉行或列，他永遠不會給出錯誤示例：如果我在 sheet2 的單元格 B5 中并希望從 sheet1 中顯示相同的資訊
=OFFSET(sheet1!$A$1;ROW(B5)-1;COLUMN(B5)-1)
只有單元格修復是 A1 sheet1
轉載請註明出處，本文鏈接：https://www.uj5u.com/net/386812.html