Question

我有一个工作表，其中包含从同一工作簿中的其他位置获取的多行数据。完整阵列来自A8：W71。这些行中的数据是数字和公式的混合。有多个空白行 - 其中公式规定行应该是＆＃34;＆＃34;。

我想要做的是将这些完整行复制到同一工作簿中的相同工作表中 - 但是缺少没有显示数据的行。

有人可以建议吗？我已经尝试了一些建议的选项 - 但似乎无法让一个人工作。我是一个中等能力的Excel用户 - 但没有专家。已经在这里推荐，这是我的第一个问题。希望它清楚我所要求的。非常感谢 - 这让我感到头晕目眩

Answer 1

我非常害羞，有人会提供紧凑的双行代码。但下面的粗野代码可以满足您的需求。

Private Sub CommandButton1_Click()
Dim temp As Integer, i As Integer, j As Integer, k As Integer

temp = 0
k = 8 ' first row for pasting results
For i = 8 To 71 'the rows
    For j = 1 To 23 ' the columns
        If Worksheets("Sheet1").Cells(i, j) <> "" Then 'if there is something in the cell, temp will no longer be 0
            temp = temp + 1
        End If
    Next
        If temp > 0 Then 'if there is something in the row, copy the row to sheet2
            Worksheets("Sheet2").Cells(k, 1).EntireRow.Value = Worksheets("Sheet1").Cells(i, 1).EntireRow.Value
            k = k + 1 'next row in Sheet2
            temp = 0 'reset for next row in sheet1
        End If
Next
End Sub

已编辑以前的答案组合，精简。代码现在简单得多。

Private Sub CopyRows()
Dim i As Integer, k As Integer

k = 8 ' first row for pasting results
For i = 8 To 71 'the rows
        If Application.WorksheetFunction.CountIf(Worksheets("SourceSheet").Rows(i), ">""") > 0 Then 'if there is something in the cell
            Worksheets("TargetSheet").Cells(k, 1).EntireRow.Value = Worksheets("SourceSheet").Cells(i, 1).EntireRow.Value
            k = k + 1
        End If
Next
End Sub

Answer 2

<强>更新这应该可以解决问题：

 Sub CopyRows()
    ' Clear TargetSheet Data
    Worksheets("TargetSheet").Rows("2:64").ClearContents
    Dim rowCount As Long, i As Long
    With Worksheets("SourceSheet")
        For i = 8 To 71
            If Application.WorksheetFunction.CountIf(.Rows(i), ">""") > 0 Then
                PasteRows i
            End If
        Next
    End With
End Sub

Sub PasteRows(i As Long)
    Dim rowCount As Long
    With Worksheets("TargetSheet")
        rowCount = .Cells(.Rows.count, 1).End(xlUp).Row + 1
        Worksheets("SourceSheet").Rows(i).Copy
        .Cells(rowCount, 1).PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
    End With
End Sub

Reedited ...大声笑谢谢CMArg !! 我的方法有点冗长。我试图让它有些通用。

我重构了CMArg的可读性组合代码

Private Sub CopyRows()
    Dim i As Integer, count As Integer, k As Integer
    Dim s As Worksheet, t As Worksheet
    Set s = Worksheets("SourceSheet")
    Set t = Worksheets("TargetSheet")
    k = 1
    For i = 8 To 71
        count = Application.WorksheetFunction.CountIf(s.Rows(i), ">""")
        If count > 0 Then
            k = k + 1
            t.Rows(k).EntireRow.Value = s.Rows(i).EntireRow.Value
        End If
    Next

End Sub

Excel 2013：将数组（所有字段都包含公式）减少为仅包含数据的行

2 个答案: