【EXCEL VBA（マクロ）】二重ループで横持データと縦持データを変換する

二重ループで変換する

このコードは、セルの範囲を二重のループで反復処理し、条件に合致する場合に別のワークシートにコピーします。データが転記される条件は、元のセルに値があり、空のセルではない場合です。処理後に、新しいシートが追加されます。

Sub 二重ループ()
  Dim 行 As Long
  Dim 列 As Long
  Dim 番号 As Long

  Dim LastRow1 As Long
    LastRow1 = ActiveSheet.Cells(Rows.Count, 2).End(xlUp).Row
  Dim LastCol1 As Long
    LastCol1 = ActiveSheet.Cells(2, Columns.Count).End(xlToLeft).Column

  Worksheets.Add(After:=ActiveSheet).Name = ActiveSheet.Name & "_" & VBA.Format(Now(), "h時mm分ss秒")

  Set Target = ActiveSheet

  ActiveSheet.Previous.Select  'ActiveSheet.Next.Activate


  番号 = 2
  For 行 = 2 To LastRow1
    For 列 = 2 To LastCol1
        If Cells(行, 列).Value <> "" Then
            Cells(行, 列).Copy ActiveSheet.Next.Cells(番号, 1)
            Cells(行, 1).Copy ActiveSheet.Next.Cells(番号, 2)
            番号 = 番号 + 1
        End If
    Next 列
  Next 行
  
  ActiveSheet.Next.Activate
  
  Cells(1, 1) = "数量"
  Cells(1, 2) = "項目"

  'ActiveSheet.Previous.Select

  MsgBox "完了 "
End Sub

横持データを縦持データにする　＊特定ワードの行を削除

Sub 二重ループ()
  Dim 行 As Long
  Dim 列 As Long
  Dim 番号 As Long

  Dim LastRow1 As Long
    LastRow1 = ActiveSheet.Cells(Rows.Count, 2).End(xlUp).Row
  Dim LastCol1 As Long
    LastCol1 = ActiveSheet.Cells(2, Columns.Count).End(xlToLeft).Column

  Worksheets.Add(After:=ActiveSheet).Name = ActiveSheet.Name & "_" & VBA.Format(Now(), "h時mm分ss秒")

  Set Target = ActiveSheet

  ActiveSheet.Previous.Select  'ActiveSheet.Next.Activate

  番号 = 2
  For 行 = 2 To LastRow1
    For 列 = 2 To LastCol1
    
        If Cells(行, 列).Value <> "" Then
            Cells(行, 1).Copy ActiveSheet.Next.Cells(番号, 1)
            Cells(1, 列).Copy ActiveSheet.Next.Cells(番号, 2)
            Cells(行, 列).Copy ActiveSheet.Next.Cells(番号, 3)
            番号 = 番号 + 1
        End If
    
    Next 列
  DoEvents
  Next 行
  
  ActiveSheet.Next.Activate
  
  Cells(1, 1) = "項目１"
  Cells(1, 2) = "項目２"
  Cells(1, 3) = "項目３"

'行の削除-------------------------------
Dim fnd As Range
Dim fnd_all As Range
Dim adr As String

Set fnd = ActiveSheet.Cells.Find(What:="総計", LookAt:=xlPart)
    If fnd Is Nothing Then
        MsgBox "見つかりませんでした。"
        Exit Sub
    Else
        Set fnd_all = fnd
        adr = fnd.Address
    End If

  Do
    DoEvents
    Set fnd = Cells.FindNext(After:=fnd)
        If fnd.Address = adr Then
            Exit Do
        Else
            Set fnd_all = Union(fnd_all, fnd)
        End If
  Loop
  
fnd_all.EntireRow.Delete
'-------------------------------

  MsgBox "完了 "
End Sub

ダミーデータのダウンロード

dummy19 ダウンロード

横持ちデータから縦持ちデータへ変換する

このコードは、横持ちのデータを縦持ちに変換するためのVBAマクロです。

Sub 横持ちから縦持ち()

With Application 
.ScreenUpdating = False
.EnableEvents = False
.Calculation = xlCalculationManual
End With        
 
    '①相手（対象シート）と範囲指定
    Dim targetSheet As Worksheet
    Set targetSheet = ThisWorkbook.ActiveSheet 'シートを指定　’Worksheets("検索")
        
        Dim MaxRow1 As Long '変数の宣言
        MaxRow1 = targetSheet.Cells(Rows.Count, 1).End(xlUp).Row '最終行の取得
        'Set rH = targetSheet.Range("A33:A" & MaxRow1)
        
        Dim MaxCol1 As Long '変数の宣言
        MaxCol1 = targetSheet.Cells(1, Columns.Count).End(xlToLeft).Column '最終列の取得
        'Set cH = targetSheet.Range("E33:E" & MaxCol1)
    
    '②結果出力シート
    Dim outputSheet As Worksheet
    Worksheets.Add(After:=ActiveSheet).Name = "Import" & "_" & VBA.Format(Now(), "h時mm分ss秒")
    
    
    ActiveSheet.Previous.Select
    
    '③処理
    Dim rowCount As Long '行数
    Dim ColumnCount As Long  '列数
    Dim OutputRow As Long    '出力行
    
    OutputRow = 2  '2行目
    For rowCount = 2 To MaxRow1  '行範囲指定
        For ColumnCount = 1 To MaxCol1  '列範囲指定
           If targetSheet.Cells(rowCount, ColumnCount).Value <> "" Then
              targetSheet.Cells(rowCount, 1).Copy ActiveSheet.Next.Cells(OutputRow, 1)
           
              targetSheet.Cells(rowCount, ColumnCount).Copy ActiveSheet.Next.Cells(OutputRow, 1)
              targetSheet.Cells(rowCount, ColumnCount + 1).Copy ActiveSheet.Next.Cells(OutputRow, 1)
              targetSheet.Cells(rowCount, 1).Copy ActiveSheet.Next.Cells(OutputRow, 2)
              targetSheet.Cells(rowCount, 3).Copy ActiveSheet.Next.Cells(OutputRow, 3)
              
              OutputRow = OutputRow + 1
           End If
        Next
    Next
    
ActiveSheet.Next.Select
    
'項目追加
ActiveSheet.Range("A1") = "氏名"
ActiveSheet.Range("B1") = "ランク"
       
'書式調整
'Columns("A").Delete　'Columns("A:E").Delete
    
Application.CutCopyMode = False

Application.Calculation = xlAutomatic  
Application.ScreenUpdating = True  
Application.DisplayAlerts = True 

MsgBox "完了"
End Sub

マクロを実行する前に、Excelアプリケーションの表示や計算方法などを一時的に変更しています。これにより、マクロの処理が高速化されます。
処理対象となるシートを設定しています。このシートの最終行と最終列を取得しています。
結果を出力するためのシートを作成しています。
処理を開始します。行と列の範囲を指定して、各セルの値を検査しています。値が空でない場合は、値をコピーして出力シートに貼り付けます。出力行番号を増やします。
結果出力シートに項目名を追加しています。
最後に、Excelアプリケーションの設定を元に戻します。

改善点としては、以下のようなものが考えられます。

コード中のMagic Numberをなるべく定数として定義することで、可読性を向上させることができます。例えば、OutputRow = 2 というコードで、数字の2が何を表しているのか不明瞭ですが、Const START_ROW = 2のように定数を定義しておけば、意図が明確になります。
データの行数と列数が大きい場合、実行時間が非常に長くなる可能性があります。この場合は、処理を高速化するために、配列にデータを読み込んでから処理を実行すると良いでしょう。
コピーする範囲が1つのセルだけであれば、Copyメソッドを使わずに、Valueプロパティを直接操作する方が高速です。
コード中のコメントは、説明が不足している箇所があるため、詳細なコメントを追加することで、可読性を向上させることができます。
処理を行うシートや範囲を、オブジェクトとして定義することで、コードの可読性を向上させることができます。例えば、TargetSheetやOutputSheetをWorksheetオブジェクトとして定義し、各メソッドやプロパティを直接操作するようにすると、コードの見通しがよくなります。