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

Question

我有一个工作表，其中包含从同一工作簿的其他地方获取的多行数据。完整数组来自 A8:W71。这些行中的数据是数字和公式的混合体。有多个空白行 - 公式规定该行应为“”。

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

谁能推荐一下？我已经尝试了一些建议的选项 - 但似乎无法让一个工作。我是一个中等能力的 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

EDITED 以前答案的组合，浓缩。现在代码简单多了。

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

已重新编辑...大声笑感谢 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：将数组（所有字段都有公式）缩减为仅包含数据的行

Excel 2013: Reducing an array (all fields have formulas) to only rows with data

arrays

excel

vba

excel-2013