![](/img/trans.png)
[英]excel VBA : how to skip blank cells between 2 cells that contain values?
[英]Skip Blank Values With PasteSpecial in Excel VBA
我已經嘗試過在網上找到的各種解決方案,但是還沒有運氣。 這是我的VBA代碼,用於從大約30張紙上復制單元並將它們全部粘貼到一張紙上。 每個工作表都有4列的公式,如果另一工作表中有值,則會顯示一個值。 像這樣:
=IF(Sheet1!A2<>"", Sheet1!A2, "")
然后在要輸出的頁面上運行宏:
Sub SummurizeSheets()
Dim ws As Worksheet
Application.ScreenUpdating = False
Sheets("Summary").Activate
For Each ws In Worksheets
If ws.Name <> "Summary" And ws.Name <> "Sheet1" Then
ws.Range("A2:D5406").Copy
Worksheets("Summary").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).PasteSpecial (xlPasteValues), SkipBlanks:=True
End If
Next ws
End Sub
輸出結果中有很多空白單元格,其中包含實際值。
我嘗試將“ SkipBlanks”變體放入其中,但這不是解決方案。 任何幫助,將不勝感激。
我在excelforum.com上為我回答了這個問題,我以為我會在這里發布解決方案,以防它對其他人有幫助。
Sub SummurizeSheets()
Dim ws As Worksheet
Application.ScreenUpdating = False
Sheets("Summary").Activate
For Each ws In Worksheets
If ws.Name <> "Summary" And ws.Name <> "Sheet1" Then
ws.Range("A2:D5406").Copy
Worksheets("Summary").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlPasteValues, SkipBlanks:=False
End If
Next ws
'Try inserting this line
'***********************************************************************
Worksheets("Summary").Select
'************************************************************************
'Find the last used row in column 1
LR = Cells(Rows.Count, 1).End(xlUp).Row
'Insert a formula in column E to return the row number of any non blank row
Range("E1:E" & LR).FormulaR1C1 = "=IF(RC[-4]="""","""",ROW())"
'Copy Paste Values to remove the formula
Range("E1:E" & LR).Value = Range("E1:E" & LR).Value
'Sort your data
ActiveWorkbook.Worksheets("Summary").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("Summary").Sort.SortFields.Add Key:=Range("E1:E" & LR) _
, SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("Summary").Sort
.SetRange Range("A1:E" & LR)
.Header = xlGuess
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
'Clear Column E
Range("E1:E" & LR).ClearContents
Range("A1").Select
End Sub
聲明:本站的技術帖子網頁,遵循CC BY-SA 4.0協議,如果您需要轉載,請注明本站網址或者原文地址。任何問題請咨詢:yoyou2525@163.com.