为非空白值复制多行和多列

Question

我正在尝试将一组数据转换为不同的格式以供导出。

我只想复制带有值的行。

从 D 列开始（见附件），我想过滤非空白值并在新工作表的五列中跨列 B、C、D、CellD2、CellD3 复制。然后对 D 列之后具有值的所有列重复相同的操作。

数据集可以有多列（无固定限制）和多行（无固定限制）。

这是我正在处理的数据（工作表名称是“LJM Fert”）

这是我想要达到的最终结果（工作表名称为“Export”）

我写的代码

Sub CopyPaste()

Dim Totalrows As Long
Dim Totalcolumns As Long
Dim rowloop As Long
Dim columnloop As Long
Dim rowcount As Long
Dim columncount As Long
Dim pastestart As Long

    Sheets("LJM Fert").Activate

    Totalrows = ActiveSheet.UsedRange.Rows.Count
    Totalcolumns = ActiveSheet.UsedRange.Columns.Count
    rowcount = 4
    columncount = 4
    pastestart = 2
        
    For rowloop = rowcount To Totalrows
        
        For columnloop = columncount To Totalcolumns
        
            If ActiveSheet.Cells(rowcount, columncount).Value <> "" Then

                ActiveSheet.Cells(rowcount, 2).Copy
                Sheets("Export").Activate
                ActiveSheet.Cells(pastestart, 1).Paste
                Sheets("LJM Fert").Activate
        
                ActiveSheet.Cells(rowcount, 3).Copy
                Sheets("Export").Activate
                ActiveSheet.Cells(pastestart, 2).Paste
                Sheets("LJM Fert").Activate
        
                ActiveSheet.Cells(rowcount, columncount).Copy
                Sheets("Export").Activate
                ActiveSheet.Cells(pastestart, 3).Paste
                Sheets("LJM Fert").Activate
       
                ActiveSheet.Cells(2, columncount).Copy
                Sheets("Export").Activate
                ActiveSheet.Cells(pastestart, 4).Paste
                Sheets("LJM Fert").Activate
        
                ActiveSheet.Cells(3, columncount).Copy
                Sheets("Export").Activate
                ActiveSheet.Cells(pastestart, 5).Paste
                Sheets("LJM Fert").Activate
        
            End If
        
            columncount = columncount + 1
            pastestart = pastestart + 1
        
        Next
    Next
                   
    Application.CutCopyMode = False
    'ThisWorkbook.Worksheets("Export").Cells(1, 1).Select

End Sub

Answer 1

你可以这样做：

'Define Variables
Dim shtExport As Worksheet, shtFert As Worksheet
Dim i As Integer
Dim cell as Range

'Assign Variables
Set shtExport = Sheets("Export")
Set shtFert = Sheets("LJM Fert")

i = 1 'first line where to copy data in Sheet "Export"

For Each cell In shtFert.Range("D4:G20") 'Go through each cell in table

    If cell.Value <> 0 Then

        shtExport.Cells(i, 1) = shtFert.Cells(cell.Row, 2) 'Column A
        shtExport.Cells(i, 2) = shtFert.Cells(cell.Row, 3) 'Column B
        shtExport.Cells(i, 3) = shtFert.Cells(cell.Row, cell.Column) 'Column C
        shtExport.Cells(i, 4) = shtFert.Cells(2, cell.Column) 'Column D
        shtExport.Cells(i, 5) = shtFert.Cells(3, cell.Column) 'Column E

    i = i + 1 'use next row in sheet Export

    End If

Next

这基本上是遍历工作表“LJM Fert”的 D4:G20 范围内的每个单元格，检查该单元格是否不同于 0，如果是：它将“复制”导出工作表中的该单元格.对于每个不同于 0 的单元格，依此类推。

无论如何，请确保您不要使用复制/粘贴，与我上面写的相比，它真的很慢。最好是设置范围或单元格，彼此相等。