Excel：〜45,000個のセルを持つ大きな列を1〜8個の行に変換します。

Question

ここに最初の投稿がありますので、私に同行してください。私が尋ねようとしているものに似た何かが掲載されているかもしれませんが、私の技術的な非識字性によって私がそれを見つけられない可能性があります。

私はデータの列が約45,000セルあります。

これらのセル内には、ID＃によって識別される個体の降順データがあり、先行するID＃に関連する基準を有する1〜8個の追加の細胞が続く。

私がしようとしているのは、この大きな列を約5,500個のIDごとに1行に変換することです。

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

私は初心者レベルSASの背景から来て、ごく簡単な方法で、以前にExcelを使用していた、そして今、週または2のためにオフとオンこれを理解しようとしています。私は手動でトランスポーズを開始しましたが、それは永遠に続く予定です。より簡単な方法があることを願っています。

これまで見たことから、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