Vba 宏提取数据块

我一整天都在解决这个问题，但解决不了

输入数据由具有相同行数和列数的多个数据块组成。每个数据块的名称都位于块内的第一行。此外，它们之间还有一个空行

block1
name score value
 a     2     3
 b     3     5
 c     1     6

block2
name score value
 a     4     6
 b     7     8
 c     2     6

block3
name score value
 a     5     4
 b     7     8
 c     2     9

所需的输出是提取每个块的名称和值列，然后在列中对它们进行并行。像这样：

value  block1  block2 block3
 a       3     6      4
 b       5     8      8
 c       6     6      9

谢谢你的帮助

更新 谢谢你的回答，托尼和其他人！ 我还有一个要求。某些表中可能缺少某些行。换句话说，正如您前面提到的，行号可能会有所不同。是否可以在这些表格的相应单元格中填入NA？i、 e.新输入如下：

block1
name score value
a     2     3
c     1     6

block2
name score value
a     4     6
b     7     8
c     2     6

block3
name score value
a     5     4
b     7     8

现在所需的输出如下所示：

value  block1  block2 block3
a       3       6      4
b       NA      8      8
c       6       6      NA

7月3日更新（如果问题太长是不合适的，我将移动此部分并将其作为新问题）

如何将值及其对应的分数都提取出来，并将它们放在一个单元格中？如下所示：代码指示将值放入动态数组中。然后将.range分配给该数组。我的第一个想法是构造另一个数组来存储“score”列的值。然后循环遍历两个数组中的每个元素，并将它们连接在一起。然而，VBA似乎确实允许我在数组中循环，因为它的维度没有定义。我试过REDIM，但没用

value  block1   block2    block3
 a       3(2)     6(4)      4(5)
 b       5(3)     8(7)      8(7)
 c       6(1)     6(2)      9(2)

---

第一个答案-问题介绍和澄清要求

 block1
name score value
 a     2     3
 b     3     5
 c     1     6

block2
name score value
 a     4     6
 b     7     8
 c     2     6

block3
name score value
 a     5     4
 b     7     8
 c     2     9

这不是一个解决方案-您没有为解决方案提供足够的信息-但介绍了问题和可能的技术。警告：我已将此输入记事本；不保证没有语法错误

你说每张桌子的大小都一样，虽然我假设不是3x3。但如果它们是3x3，我能说表1从第1行开始，表2从第7行开始，表N从6（N-1）+1开始吗？也就是说，您可以计算每个表的位置，还是需要搜索

如果需要搜索，以下内容可能会有所帮助：

Dim ColSrcLast as Long
Dim RowSrcCrnt As Long

RowSrcCrnt = 1      ' Assumed start of Table 1

With Worksheets("xxxx")
  ColSrcLast = .Cells(RowCrnt,Columns.Count).End(xlToLeft).Column
End With

ColSrcLast=.Cells（RowCrnt，Columns.Count）.End（xlToLeft）.Column

是VBA的等效项，它将光标放在RowCrnt+1行的最后一列，然后单击Control+Left。这可能是查找表1中最后使用的列的最简单方法

Control+箭头键按指示方向移动光标，并：

• 如果当前单元格为空，则在第一个非空单元格处停止
• 如果当前单元格和下一个单元格均为非空单元格，则在空白单元格之前的最后一个非空单元格处停止
• 如果当前单元格为非空，但下一个单元格为空，则在下一个非空单元格处停止
• 如果没有单元格满足上述条件，则在范围结束时停止

实验和以上将变得更加清晰

如果表之间的空行数可能不同，我认为以下是查找每个表的最简单方法：

Dim Found As Boolean
Dim RowSrcCrnt As Long
Dim RowSrcLast As Long
Dim RowSrcTableTitle As Long
Dim RowSrcTableLast As Long

With Worksheets("xxxx")
  ' Find last used row of worksheet
  RowSrcLast = .Cells(Rows.Count,"A").End(xlUp).Row
End With

RowSrcCrnt = 1

Do While RowSrcCrnt <= RowSrcLast
  With Worksheets("xxxx")
    Found = False
    Do While RowSrcCrnt <= RowSrcLast
      If .Cells(RowSrcCrnt,"A").Value = "" then
        ' Have found start of next (first) table
        RowSrcTableTitle = RowSrcCrnt
        Found = True
        Exit Do
      End If 
      RowSrcCrnt = RowSrcCrnt+1
    Loop
    If Not Found Then
      ' No more tables
      Exit Do
    End If
    RowSrcTableLast = .Cells(RowSrcTableTitle,"A").End(xlDown).Row
  End With

  ' Process table RowSrcTableTitle to RowSrcTableLast

  RowSrcCrnt = RowSrcTableLast+1
Loop

对于表格，您需要更改常量TableHeight和TableWidth的值。您还必须将“Jia源”更改为源工作表的名称

Option Explicit
Sub ExtractValue()

  Dim ColSrcLeft As Long
  Dim ColSrcRight As Long
  Dim RowSrcTitle As Long   ' First row or table
  Dim RowSrcHeader As Long  ' Header row of table
  Dim RowSrcEnd As Long     ' Last row of table

  Const TableHeight As Long = 4
  Const TableWidth As Long = 3

  RowSrcTitle = 1
  Do While True
    With Worksheets("Jia Source")
      If .Cells(RowSrcTitle, "A").Value = "" Then
        Exit Do
      End If
      RowSrcHeader = RowSrcTitle + 1
      RowSrcEnd = RowSrcHeader + TableHeight
      ColSrcLeft = 1
      ColSrcRight = ColSrcLeft + TableWidth - 1
      Debug.Print "Table " & colNumToCode(ColSrcLeft) & RowSrcTitle & ":" & _
                  colNumToCode(ColSrcRight) & RowSrcEnd
    End With

    ' Code to handle table goes here.

    RowSrcTitle = RowSrcEnd + 2

  Loop

End Sub
Function colNumToCode(ByVal colNum As Integer) As String

  ' Convert Excel column number to column identifier or code
  ' Last updated 3 Feb 12.  Adapted to handle three character codes.

  Dim code As String
  Dim partNum As Integer

  If colNum = 0 Then
    colNumToCode = "0"
  Else
    code = ""
    Do While colNum > 0
      partNum = (colNum - 1) Mod 26
      code = Chr(65 + partNum) & code
      colNum = (colNum - partNum - 1) \ 26
    Loop
    colNumToCode = code
  End If

End Function

我留下的代码显示了如何搜索大小不同的表。如果上述代码不能为工作表生成正确的结果，则可能需要合并这两个例程

以下假设RowSrcTitle、RowSrcHeader、RowSrcLast、ColSrcLeft和ColSrcRight是正确的。它是ExtractValue（）中的代码，加上将数据复制到我命名为“Jia destination”的目标工作表的代码。其产出是：

玩一玩。如果有必要，带着问题回来

Sub ExtractValue2()

  Dim ColDestCrnt As Long
  Dim ColSrcCrnt As Long
  Dim ColSrcLeft As Long
  Dim ColSrcRight As Long
  Dim Found As Boolean
  Dim RowDestBottom As Long
  Dim RowDestTop As Long
  Dim RowSrcTitle As Long   ' First row or table
  Dim RowSrcHeader As Long  ' Header row of table
  Dim RowSrcEnd As Long     ' Last row of table
  Dim TableTitle As String
  Dim CellArray() As Variant

  Const TableHeight As Long = 4
  Const TableWidth As Long = 3

  RowSrcTitle = 1
  ColDestCrnt = 1
  RowDestTop = 1
  RowDestBottom = RowDestTop + TableHeight

  Do While True
    With Worksheets("Jia Source")
      If .Cells(RowSrcTitle, "A").Value = "" Then
        Exit Do
      End If
      RowSrcHeader = RowSrcTitle + 1
      RowSrcEnd = RowSrcHeader + TableHeight
      ColSrcLeft = 1
      ColSrcRight = ColSrcLeft + TableWidth - 1

    End With

    If ColDestCrnt = 1 Then
      ' Column 1, the list of names, has not been output.
      ' This assumes all tables have the same rows in the same
      ' sequence

      With Worksheets("Jia Source")
        ' This statement loads all the values in a range to an array in a
        ' single statements.  Ask if you want more detail on what I am doing.
        ' Load name column for this table
        CellArray = .Range(.Cells(RowSrcHeader, ColSrcLeft), _
                           .Cells(RowSrcEnd, ColSrcLeft)).Value
      End With
      With Worksheets("Jia Destination")
        ' Clear destination sheet
        .Cells.EntireRow.Delete
        ' Write array containing name column to destination sheet
        .Range(.Cells(RowDestTop, 1), _
                 .Cells(RowDestBottom, 1)).Value = CellArray
      End With
      ColDestCrnt = ColDestCrnt + 1
    End If

    With Worksheets("Jia Source")
      ' Find Value column.
      Found = False
      For ColSrcCrnt = ColSrcLeft + 1 To ColSrcRight
        If LCase(.Cells(RowSrcHeader, ColSrcCrnt).Value) = "value" Then
          Found = True
          Exit For
        End If
      Next
    End With
    ' If Found is False, the table has no value column and is ignored
    If Found Then
      With Worksheets("Jia Source")
        ' Extract title of title
        TableTitle = .Cells(RowSrcTitle, ColSrcLeft).Value
        ' Load name column (excluding header) for this table
          CellArray = .Range(.Cells(RowSrcHeader + 1, ColSrcCrnt), _
                             .Cells(RowSrcEnd, ColSrcCrnt)).Value
      End With
      With Worksheets("Jia Destination")
        ' Copy title
        .Cells(1, ColDestCrnt).Value = TableTitle
        ' Write array containing name column to destination sheet
        .Range(.Cells(RowDestTop + 1, ColDestCrnt), _
               .Cells(RowDestBottom, ColDestCrnt)).Value = CellArray
      End With
      ColDestCrnt = ColDestCrnt + 1
    End If

    RowSrcTitle = RowSrcEnd + 2

  Loop

End Sub

---

对新问题的回答

 block1
name score value
 a     2     3
 b     3     5
 c     1     6

block2
name score value
 a     4     6
 b     7     8
 c     2     6

block3
name score value
 a     5     4
 b     7     8
 c     2     9

如果您的最终澄清是正确的，则此代码比您需要的更复杂。在您发布它之前，我已经创建了一个例程，它能够处理比您认为需要的更多种类的表。因为您没有看到“真实”文件，所以我没有删除代码来处理完整的、可能的复杂性

我创建了一个测试工作表，如下所示：

value  block1  block2 block3
a       3       6      4
b       NA      8      8
c       6       6      NA

我建议你复制这份工作表，因为它包含了我能想到的所有棘手问题。使用此工作表尝试此代码。试着理解代码在做什么以及为什么。然后你应该准备好面对真正的桌子扔给你的任何东西

有些代码很复杂，我必须定义一个用户定义的数据类型。我试着在谷歌上搜索“vba用户定义的数据类型”，但对我找到的教程感到非常失望，所以我将自己尝试一下

假设我的宏需要保存许多人的姓名和年龄。我显然需要一些阵列：

Dim NameFamily() As String
Dim NameGiven() As String
Dim Age() As Long

ReDim NameFamily(1 to 20)
ReDim NameGiven(1 to 3, 1 to 20)
ReDim Age(1 to 20)

NameFamily(5) = "Dallimore"
NameGiven(1, 5) = "Anthony"
NameGiven(2, 5) = "John"
NameGiven(3, 5) = ""
Age(5) = 65

你可以很容易地得到很多难以维护的代码；尤其是随着人均变量数量的增加

另一种方法是使用大多数语言称之为结构，VBA称之为用户定义的数据类型：

Type Person
  NameFamily As String
  NameGiven() As String
  NumGivenNames as Long
  Age As Long
 End Type

Person是一种新的数据类型，我可以使用此类型声明变量：

Dim Boss As Person
Dim OtherStaff() As Person

ReDim OtherStaff(1 to 20)

OtherStaff(5).NameFamily = "Dallimore"
OtherStaff(5).NumGivenNames = 2
Redim OtherStaff(5).NameGiven(1 To OtherStaff(5).NumGivenNames) 
OtherStaff(5).NameGiven(1) = "Anthony"
OtherStaff(5).NameGiven(2) = "John"
OtherStaff(5).Age = 65

这看起来可能并不容易。当你想添加另一项关于人的信息时，好处变得更加明显；也许有很多孩子。对于常规数组，首先必须添加一个新数组。然后，您必须找到代码中调整person数组大小的每个点，并为新数组添加一条ReDim语句。如果你错过了任何一次重播，你会出现奇怪的错误。对于用户定义的数据类型，可以向类型定义中添加一行：

Type Person
  NameFamily As String
  NameGiven() As String
  NumGivenNames as Long
  Age As Long
  NumChildren As Long 
 End Type

对于这个新变量，所有现有代码现在都已完全更新

上面是一个非常简短的介绍，但我相信它涵盖了我在代码中使用的用户定义数据类型的每个特性

我希望我已经包含了足够的注释，让您能够理解我的代码。慢慢完成，必要时提问

下面的代码是已更新的第三个版本