英文:
Removing empty rows and shifting remaining rows up in a range before copying and pasting another range
问题
我还在学习VBA的各种细节。我有两个范围：(A:E)和(F:J)。它们需要合并成一个范围。第一个范围有空行，需要删除。删除这些行后，剩下的行会上移。然后将第二个范围复制并粘贴在下方。
我们如何解决当前的空列和单元格问题？
Dim ws As Worksheet
Dim firstRng As Range
Dim secondRng As Range
Dim i As Long
' 设置工作表和范围
Set ws = ThisWorkbook.Worksheets("Sheet1 (5)")
' 定义范围1
With ws
Set firstRng = Range(.Cells(1, 1), .Cells(.Rows.Count, 6).End(xlUp))
End With
' 从firstRng中删除空行并上移
For i = firstRng.Rows.Count To 1 Step -1
If Application.WorksheetFunction.CountA(firstRng.Rows(i)) = 0 Then
firstRng.Rows(i).Delete Shift:=xlUp
End If
Next i
' 定义范围2
With ws
Set secondRng = Range(.Cells(1, 6), .Cells(.Rows.Count, 10).End(xlUp))
End With
' 将第二个范围粘贴在第一个范围下方
secondRng.Copy ws.Cells(firstRng.Rows.Count + 1, 1)
secondRng.ClearContents
结果的照片。
英文:
Still learning the ins and outs of VBA. I have two ranges: (A:E) and (F:J). They need to be condensed into a singular range. The first range has empty rows, which need to be deleted. After these rows are deleted, the remaining rows are shifted up. The second range is then copied and pasted underneath.
How would we fix the current issue with empty columns & cells?
Dim ws As Worksheet
Dim firstRng As Range
Dim secondRng As Range
Dim i As Long
'Setting worksheets and Ranges
Set ws = ThisWorkbook.Worksheets("Sheet1 (5)")
' Define Range 1
With ws
Set firstRng = Range(.Cells(1, 1), .Cells(.Rows.Count, 6).End(xlUp))
End With
' Removing empty rows from firstRng and shifting up
For i = firstRng.Rows.Count To 1 Step -1
If Application.WorksheetFunction.CountA(firstRng.Rows(i)) = 0 Then
firstRng.Rows(i).Delete Shift:=xlUp
End If
Next i
' Define Range 2
With ws
Set secondRng = Range(.Cells(1, 6), .Cells(.Rows.Count, 10).End(xlUp))
End With
' Paste second range below first
secondRng.Copy ws.Cells(firstRng.Rows.Count + 1, 1)
secondRng.ClearContents
'
End Sub
Photos of the result.
答案1
得分: 2
这实际上比你试图做的要简单。这假设两个范围中的最后一行都有第5列（E列和J列）中的非空单元格。如果其中任何一个单元格为空（在这种情况下，“End-Up”将无法找到正确的行），则会失败。
Sub RemoveRows()
Dim ws As Worksheet
Dim firstRng As Range
Dim secondRng As Range
Dim i As Long
' 设置工作表和范围
Set ws = ThisWorkbook.Worksheets("Sheet1")
' 定义范围1
With ws
Set firstRng = Range(.Cells(1, 1), .Cells(.Rows.Count, 5).End(xlUp))
End With
' 从第一个范围中删除空行并向上移动
For i = firstRng.Rows.Count To 1 Step -1
If Application.WorksheetFunction.CountA(firstRng.Rows(i)) = 0 Then
firstRng.Rows(i).Delete Shift:=xlUp
End If
Next i
' 定义范围2
With ws
Set secondRng = Range(.Cells(1, 6), .Cells(.Rows.Count, 10).End(xlUp))
End With
' 在第一个范围下方粘贴第二个范围
secondRng.Copy ws.Cells(firstRng.Rows.Count + 1, 1)
secondRng.ClearContents
End Sub
编辑
不确定你所说的循环永远不会结束是什么意思。这里没有无限循环：
英文:
It's actually simpler than you're trying to make it. This assumes that the last row in both ranges has a non-empty cell in the 5th column (columns E and J). It will fail if either of those cells is empty (the End-Up will not find the correct row in that case).
Sub RemoveRows()
Dim ws As Worksheet
Dim firstRng As Range
Dim secondRng As Range
Dim i As Long
'Setting worksheets and Ranges
Set ws = ThisWorkbook.Worksheets("Sheet1")
' Define Range 1
With ws
Set firstRng = Range(.Cells(1, 1), .Cells(.Rows.Count, 5).End(xlUp))
End With
' Removing empty rows from firstRng and shifting up
For i = firstRng.Rows.Count To 1 Step -1
If Application.WorksheetFunction.CountA(firstRng.Rows(i)) = 0 Then
firstRng.Rows(i).Delete Shift:=xlUp
End If
Next i
' Define Range 2
With ws
Set secondRng = Range(.Cells(1, 6), .Cells(.Rows.Count, 10).End(xlUp))
End With
' Paste second range below first
secondRng.Copy ws.Cells(firstRng.Rows.Count + 1, 1)
secondRng.ClearContents
End Sub
Edit
Not sure what you mean by the loop never concludes. Nothing infinite here:
通过集体智慧和协作来改善编程学习和解决问题的方式。致力于成为全球开发者共同参与的知识库，让每个人都能够通过互相帮助和分享经验来进步。
评论