VBA發現價值並複製基於單元格格式連續行

Question

目前，我有下面的代碼將通過看工作表4找到「滑件」的第一個實例列A

Dim LastRow1 As Long 
Dim i1 As Integer 
    For Each ws In Application.ThisWorkbook.Worksheets 
     LastRow1 = ws.Cells(Rows.Count, 1).End(xlUp).Row 
     i1 = 1 

     Do While i1 <= LastRow1 
      If ws.Range("A" & i1).Value = "Slide1" Then 
       ws.Rows(i1 & ":" & i1 + 2).Copy Sheets("Summary").Range("A105") 
      On Error Resume Next 
      End If 
      i1 = i1 + 1 
     Loop 
    Next 

這工作好嗎，但有時我需要複製的值包含2行以上。

我想包括一些邏輯，設置列a中具有特定xlEdgeLeft權重和樣式（類似於下面）中的最後一個單元格的結束行。這是我試圖清理的混亂中最獨特和最一致的格式。

.Borders(xlEdgeLeft).LineStyle = 1 AND .Borders(xlEdgeLeft).Weight = 4 

有人可以幫助我如何做到這一點嗎？我想我需要創建一個新的變量來替換「i1 + 2」，當A列停止使用上面的xlEdgeLeft格式時，這個變量基本上可以算出來。

Answer 1

我還沒有測試過這個功能，但是玩了一下這個Do-While循環，我把它添加到你的代碼中，你應該可以到達那裏。

Dim copiedRows as Integer 
Dim i2 as Integer 
Do While i1 <= LastRow1 
    copiedRows = 0 
    i2 = i1 
    If ws.Range("A" & i1).Value = "Slide1" Then 
     Do While ws.Range("A" & i2).Borders(xlEdgeLeft).LineStyle = 1 AND .Borders(xlEdgeLeft).Weight = 4 
      copiedRows= copiedRows+1 
      i2 = i2 + 1 
     Loop 
     ws.Rows(i1 & ":" & i1 + copiedRows).Copy Sheets("Summary").Range("A105") 
     On Error Resume Next 
    End If 
    i1 = i1 + 1 
Loop 

Answer 2

這樣做。這是最後一個例子。 If ws.Range找到第一條記錄，然後找到從下一行開始的具有指定邊界的所有記錄

Dim ws As Excel.Worksheet 
Dim LastRow1 As Long 
Dim i1 As Integer 
Dim i2 As Integer 
Dim copiedRows As Integer 

For Each ws In Application.ThisWorkbook.Worksheets 
LastRow1 = ws.Cells(Rows.Count, 1).End(xlUp).Row 
i1 = 1 

Do While i1 <= LastRow1 
    copiedRows = 0 
    i2 = i1 
    If ws.Range("A" & i1).Value = "Report" And ws.Range("A" & i1 + 1).Value = "Quarter" Then 
     Do While ws.Range("A" & i2 + 1).Borders(xlEdgeLeft).LineStyle = 1 And ws.Range("A" & i2 + 1).Borders(xlEdgeLeft).Weight = 4 
      i2 = i2 + 1 
      copiedRows = copiedRows + 1 
     Loop 
     ws.Rows(i1 & ":" & i1 + copiedRows).Copy Sheets("Summary").Range("A1") 
     On Error Resume Next 
    End If 
    i1 = i1 + 1 
Loop 
Next 
End Sub