excel - 如果单元格包含 VBA 中的数字，如何复制相应的行标题和列标题？

Question

我提取了需要采用表格格式的杂乱原始数据。


这是我的目标:


该代码产生以下结果:

Sub sample()

Dim rnge As Range, erow As Long

lastRow = Worksheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row

For i = 2 To lastRow
    If IsNumeric(Worksheets("Sheet1").Cells(i, 2).Value) = True Then

        Worksheets("Sheet1").Cells(i, 1).Copy            
        erow = Worksheets("Sheet2").Cells(Rows.Count, 1).End(xlUp).Row            
        Worksheets("Sheet1").Paste Destination:=Worksheets("Sheet2").Cells(erow + 1, 1)

        Worksheets("Sheet1").Cells(i, 2).Copy            
        Worksheets("Sheet1").Paste Destination:=Worksheets("Sheet2").Cells(erow + 1, 3)

        Worksheets("Sheet1").Cells(1, 2).Copy            
        Worksheets("Sheet1").Paste Destination:=Worksheets("Sheet2").Cells(erow + 1, 2)                        
    End If        
Next i

End Sub

根据结果​​，有没有办法删除那些没有数值的数据？一旦 B 列完成，for 循环函数是否可以在不重新编写特定代码的情况下移入 C 列？

Answer 1

下面的代码将为您提供所需的结果，请参阅代码中的注释以进行解释。

Option Explicit


Sub sample()

Dim i As Long, pRow As Long, LastRow As Long, LastCol As Long, Col As Long
Dim Sht As Worksheet, ResSht As Worksheet

Set Sht = ThisWorkbook.Sheets("Sheet1") ' <-- rename worksheet to fit your need
Set ResSht = ThisWorkbook.Sheets("Results") ' <-- rename worksheet to fit your need

Application.ScreenUpdating = False

With Sht
    LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
    LastCol = .Cells(1, .Columns.Count).End(xlToLeft).Column ' get last column (Header row of Animals)

    ' add header row in "Results"
    ResSht.Range("A1").Value = "Colors"
    ResSht.Range("B1").Value = "Animals"
    ResSht.Range("C1").Value = "Value"
    pRow = 2

    For i = 2 To LastRow ' loop through rows
        ' loop through columns
        For Col = 2 To LastCol
            ' check if there's a numeric value in cell (and not empty)
            If IsNumeric(.Cells(i, Col).Value) And Trim(.Cells(i, Col).Value) <> "" Then
                ' add new row to "Results"
                ResSht.Range("A" & pRow).Value = .Range("A" & i).Value ' get the color from column A
                ResSht.Range("B" & pRow).Value = .Cells(1, Col).Value ' get the Animal from the header row
                ResSht.Range("C" & pRow).Value = .Cells(i, Col).Value ' get the Value from the cell

                pRow = pRow + 1
            End If
        Next Col
    Next i

End With

Application.ScreenUpdating = True

End Sub