Excel：将〜45,000个单元格的大列移位到1-8行ID绑定的行中

Question

第一篇文章很适合我。我可能会提出类似于我要问的一些问题，但是我的技术文盲可能会阻止我找到它。

我有一列数据〜45,000个单元格。

在这些单元内，存在由ID＃标识的个人的降序数据，随后是1-8个具有与前述ID＃相关的标准的附加单元的任何地方。

我想要做的事情就是将这个大列转换为每个〜5,500个ID的行。

Here is an example of what I'm trying to achieve

我来自一个初学者水平SAS背景，只在一个非常简短的方式使用的Excel之前，并一直在试图和关闭这出一两个星期了。我已经开始将它们手动转换，但这将持续下去，我希望有一个更简单的方法。

从我迄今为止所见到的情况来看，我最好的猜测是可以编写VBA代码，但我不知道从哪里开始。我也接受任何其他想法如何实现我想要得到的结果。

提前致谢！

Answer 1

如果我正确理解你的问题，下面的代码应该解决它;

Sub ColToRow() 
    Dim inCol As Range 
    Set inCol = Application.InputBox(Prompt:="Please Select Range", Title:="Range Select", Type:=8) 'Get the input column as a range 

    Dim outCol As Range 
    Set outCol = inCol.Offset(0, 2) 'Set the output column as a range 

    Dim index As Long 'Current row 
    Dim cell As Range 'Current cell 

    Dim lastRow As Long 'The last row 
    Dim currRow As Long 'Current output row 
    Dim currCol As Long 'Current output column 

    lastRow = inCol.SpecialCells(xlCellTypeLastCell).Row 
    currRow = inCol.Row - 1 
    currCol = 0 

    For index = inCol.Row To lastRow 
     Set cell = ActiveSheet.Cells(index, inCol.Column) 'Set the cell range to the current cell 

     If Application.WorksheetFunction.IsNumber(cell) And Len(cell.Value) = 7 Then 'If numeric then we assume it is the ID, else we assume it is the 
      currRow = currRow + 1 'Advance to next output row 
      currCol = 0   'Reset column offset 
      cell.Copy Destination:=ActiveSheet.Cells(currRow, outCol.Column + currCol) 'Copy ID 
     ElseIf currRow > 0 Then 'Ensure we are within the row bounds and not at 0 or below 
      currCol = currCol + 1 'Advance the column 
      cell.Copy Destination:=ActiveSheet.Cells(currRow, outCol.Column + currCol) 'Copy Text Values until we get the next numeric value 
     End If 
    Next index 'Advance the row 
End Sub 

代码只是沿着（按顺序）在列的下面，并执行以下操作;
- 如果单元格具有数值，那么我们假定它是ID并创建一个新行。
- 如果单元格有一个文本值，我们只是将它添加到当前行的下一列中，它将继续使用多个字符串值执行此操作，直到达到新的ID。

希望它有帮助。

-Regards 马克

Answer 2

---

Sub TransposeData() 
    Dim Data, TData 
    Dim x As Long, x1 As Long, y As Long 

    With Worksheets("Sheet1") 
     Data = .Range("A1", .Range("A" & .Rows.Count).End(xlUp)) 
    End With 

    ReDim TData(1 To UBound(Data, 1), 1 To 8) 

    For x = 1 To UBound(Data, 1) 
     'If the Data macthes the ID pattern (7 Digits) then 
     'increment the TData Row Counter 
     If Data(x, 1) Like "#######" Then 
      x1 = x1 + 1 
      y = 0 
     End If 
     'Increment the TData Column Counter 
     y = y + 1 
     TData(x1, y) = Data(x, 1) 
    Next 

    With Worksheets("Sheet2") 
     With .Range("A" & .Rows.Count).End(xlUp) 
      If .Value = "" Then 'If there is no data, start on row 1 
       .Resize(x1, 8).Value = TData 'Resize the range to fit the used elements in TData 
      Else ' Start on the next empty row 
       .Offset(1).Resize(x1, 8).Value = TData 
      End If 
     End With 
    End With 
End Sub 

Answer 3

另一种可能的解决方案，是根据ID为7位数字和所有其它号码暂时不

Option Explicit 

Sub main() 
    Dim area As Range 
    Dim iArea As Long 

    With ThisWorkbook.Worksheets("Transpose") '<--| reference relevant worksheet (change "Transpose" to your actual sheet name) 
     With .Range("A1", .Cells(.Rows.COUNT, 1).End(xlUp).Offset(1)) 
      .Cells(.Rows.COUNT, 1).Value = 1111111 '<--| add a "dummy" ID to end data 
      .AutoFilter Field:=1, Criteria1:=">=1000000", Operator:=xlAnd, Criteria2:="<=9999999" '<--| filter its "JobCol_Master" named range on textbox ID 
      .Cells(.Rows.COUNT, 1).ClearContents '<--| remove "dummy" ID 
      With .SpecialCells(xlCellTypeVisible) 
       .Parent.AutoFilterMode = False 
       For iArea = 1 To .Areas.COUNT - 1 
        Set area = .Parent.Range(.Areas(iArea), .Areas(iArea + 1).Offset(-1)) 
        .Parent.Cells(.Parent.Cells.Rows.COUNT, 3).End(xlUp).Offset(1).Resize(, area.Rows.COUNT).Value = Application.Transpose(area.Value) 
       Next iArea 
      End With 
     End With 
    End With 
End Sub