VBA 中的数组：对于特定行，给我值（对应于列）并跳过空白单元格

Question

我目前在 VBA 中遇到了几个问题。我有一个包含多行和多列的数据集。

示例为：

   A     B        C       D       E      F    ...
1 Name    Food 1   Food 2  Food 3  Food4  Food 5 ...
2 Ami  Oranges  Twix            Pizza  Grapes
3 Ben  Banana   Apples  Eggs           Coke
4 Mike Peaches                  Burger Coffee
5 Lea  Peas     Berries Cake    Chips  Sprite        
...

我想做的是通过数组读取数据，这样它会返回以下结果：

Name    Food 1   Food 2  Food 4  Food 5 ...
Ami     Oranges  Twix    Pizza   Grapes

相应名称的食物，但不包括空白单元格或列。

我确实找到了一个有用的 Youtube 视频，视频中代码的唯一问题是它为每一行创建了一个新工作表！！我不想要，因为在工作簿中已经有一个指定的工作表，它应该出现在其中。稍后将在 outlook 项目中用作 table。

我从 Youtube 上得到的代码如下：

 Dim CompInfo(0 To 170, 1 To 21)
 Dim r As Long, c As Long
 Const StartRow As Long = 1
 Dim ShNew As Worksheet
 
 For r = 0 To 170
 
     For c = 1 To 21
         CompInfo(r, c) = Cells(r + StartRow, c).Value
     Next c
 Next r
 
 For r = 0 To 170
     Set ShNew = Worksheets.Add
     ShNew.Name = CompInfo(r, 2)
    
 'Setting the headers
     ShNew.Range("A1").Value = CompInfo(0, 1)
     ShNew.Range("B1").Value = CompInfo(0, 2)
     ShNew.Range("C1").Value = CompInfo(0, 3)
     ShNew.Range("D1").Value = CompInfo(0, 4)
     ShNew.Range("E1").Value = CompInfo(0, 5)
     ShNew.Range("F1").Value = CompInfo(0, 6)
     ShNew.Range("G1").Value = CompInfo(0, 7)
     ShNew.Range("H1").Value = CompInfo(0, 8)
     ShNew.Range("I1").Value = CompInfo(0, 9)
     ShNew.Range("J1").Value = CompInfo(0, 10)
     ShNew.Range("K1").Value = CompInfo(0, 11)
     ShNew.Range("L1").Value = CompInfo(0, 12)
     ShNew.Range("M1").Value = CompInfo(0, 13)
     ShNew.Range("N1").Value = CompInfo(0, 14)
     ShNew.Range("O1").Value = CompInfo(0, 15)
     ShNew.Range("P1").Value = CompInfo(0, 16)
     ShNew.Range("Q1").Value = CompInfo(0, 17)
     ShNew.Range("R1").Value = CompInfo(0, 18)
     ShNew.Range("S1").Value = CompInfo(0, 19)
     ShNew.Range("T1").Value = CompInfo(0, 20)
     ShNew.Range("U1").Value = CompInfo(0, 21)
     

 'Setting the accounts

     ShNew.Range("A2").Value = CompInfo(r, 1)
     ShNew.Range("B2").Value = CompInfo(r, 2)
     ShNew.Range("C2").Value = CompInfo(r, 3)
     ShNew.Range("D2").Value = CompInfo(r, 4)
     ShNew.Range("E2").Value = CompInfo(r, 5)
     ShNew.Range("F2").Value = CompInfo(r, 6)
     ShNew.Range("G2").Value = CompInfo(r, 7)
     ShNew.Range("H2").Value = CompInfo(r, 8)
     ShNew.Range("I2").Value = CompInfo(r, 9)
     ShNew.Range("J2").Value = CompInfo(r, 10)
     ShNew.Range("K2").Value = CompInfo(r, 11)
     ShNew.Range("L2").Value = CompInfo(r, 12)
     ShNew.Range("M2").Value = CompInfo(r, 13)
     ShNew.Range("N2").Value = CompInfo(r, 14)
     ShNew.Range("O2").Value = CompInfo(r, 15)
     ShNew.Range("P2").Value = CompInfo(r, 16)
     ShNew.Range("Q2").Value = CompInfo(r, 17)
     ShNew.Range("R2").Value = CompInfo(r, 18)
     ShNew.Range("S2").Value = CompInfo(r, 19)
     ShNew.Range("T2").Value = CompInfo(r, 20)
     ShNew.Range("U2").Value = CompInfo(r, 21)

 Next r
 
End Sub

现在这段代码给出了我想要的部分内容，但如果我不需要为每一行创建一个新工作表就可以得到它。更不用说我还尝试添加它不应该 show/print 那些空的单元格，即使上面的单元格已填充。

 
 If Range("C1").Select <> "" And Range("C2").Select = "" Then
     Range("C1:C2").Offset(0, 1).Select
 End If

那么我做错了什么？如果有人能帮助我就太好了:)

非常感谢

Answer 1

导出到另一个工作表

Option Explicit

Sub ExportNamesAndFood()
    
    ' s - Source
    Const sName As String = "Sheet1"
    ' d - Destination
    Const dName As String = "Sheet2"
    Const dFirst As String = "A2"
    
    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code

    Dim sws As Worksheet: Set sws = wb.Worksheets(sName)
    Dim srg As Range: Set srg = sws.Range("A1").CurrentRegion
    Dim srCount As Long: srCount = srg.Rows.Count
    If srCount < 2 Then Exit Sub ' no data or only headers
    Dim cCount As Long: cCount = srg.Columns.Count
    Dim drCount As Long: drCount = (srCount - 1) * 2
    
    Dim sData As Variant: sData = srg.Value
    Dim dData As Variant: ReDim dData(1 To drCount, 1 To cCount)
    
    Dim sr As Long
    Dim sc As Long
    Dim dr As Long
    Dim dc As Long
    
    For sr = 2 To srCount
        If Len(CStr(sData(sr, 1))) > 0 Then ' name found
            ' Name
            dr = dr + 2
            dData(dr - 1, 1) = sData(1, 1)
            dData(dr, 1) = sData(sr, 1)
            ' Food
            dc = 1
            For sc = 2 To cCount
                If Not IsEmpty(sData(sr, sc)) Then ' food found
                    dc = dc + 1
                    dData(dr - 1, dc) = sData(1, sc)
                    dData(dr, dc) = sData(sr, sc)
                'Else ' food not found
                End If
            Next sc
        'Else ' no name found
        End If
    Next sr
    
    Dim dws As Worksheet: Set dws = wb.Worksheets(dName)
    Dim dCell As Range: Set dCell = dws.Range(dFirst)
    Dim drg As Range: Set drg = dCell.Resize(dr, cCount)
    
    drg.Value = dData
    
    MsgBox "Data exported.", vbInformation

End Sub

VBA 中的数组：对于特定行，给我值（对应于列）并跳过空白单元格

Array in VBA: For a specific row, gives me the values (corrresponding to the column) and skips the blank cells

arrays

excel

vba

multidimensional-array

导出到另一个工作表