新規シート記入／別シートとマッチング／複数項目取得／新規シート貼付け
このコードは、2つのエクセルシートから、指定された列にある複数の項目を取得し、新しいシートに出力するものです。
Sub 複数項目取得()
'辞書オブジェクトを作成
Dim objDIC As Object
Set objDIC = CreateObject("Scripting.Dictionary")
Dim myKey As Variant
Dim i As Long
'アクティブシート：キーとアイテム取得
With ThisWorkbook.ActiveSheet
For i = 2 To .Cells(.Rows.Count, 1).End(xlUp).Row
objDIC(.Cells(i, 1).Value) = _
.Cells(i, "B").Value & "," & .Cells(i, "E").Value & "," & .Cells(i, "T").Value
Next i
End With
'アクティブシートの右隣のシート：キーとアイテム取得
With ThisWorkbook.ActiveSheet.Next
For i = 2 To .Cells(.Rows.Count, 1).End(xlUp).Row
objDIC(.Cells(i, 1).Value) = _
.Cells(i, "C").Value & "," & .Cells(i, "E").Value & "," & .Cells(i, "G").Value
Next i
End With
'「objDIC」からkeyを、配列変数（一次）に取り出す
myKey = objDIC.Keys
'新規シートへ出力
Worksheets.Add(After:=ActiveSheet).Name = _
ActiveSheet.Name & "_" & VBA.Format(Now(), "h時mm分ss秒")
With ThisWorkbook.ActiveSheet
For i = 1 To objDIC.Count
.Cells(i + 1, "A").Value = myKey(i - 1)
.Range(.Cells(i + 1, "B"), .Cells(i + 1, "D")).Value = _
Split(objDIC(myKey(i - 1)), ",")
Next i
End With
MsgBox "完了"
End Sub解説
Microsoft Scripting Runtimeライブラリを使用して、辞書オブジェクトを作成しています。辞書オブジェクトを使用することで、キーと値のペアを保持することができます。
アクティブシートから指定された列（1列目、B列、E列、T列）の値を取得し、辞書オブジェクトにキーと値のペアとして保存しています。キーは1列目、値はB列、E列、T列の値をカンマ区切りで連結した文字列です。
アクティブシートの隣のシートからも同様に値を取得し、辞書オブジェクトに保存しています。ここで、キーが重複する場合は、後に取得した値で上書きされます。
辞書オブジェクトのキーを配列変数に取り出しています。これにより、後で取得したキーを元に、値を取得できるようになります。
新しいシートを作成しています。そして、辞書オブジェクトからキーを取り出し、それを新しいシートのA列に書き込んでいます。また、対応する値をカンマ区切りで分割し、新しいシートのB列からD列に記入します。
- キー：A列
- アイテム：B列、E列、T列の値（「,(カンマ)」を挟みながら１つの文字列として連想配列
（objDICのItem部に格納)
空白行を除いて隣の列に転記
このVBAコードは、Excelのワークシートの列Aからデータを読み込み、空白でないセルの内容を隣の列Bに転記するマクロです。
Sub 空白以外のセルを隣の列に転記()
Dim i As Long
Dim LastRow As Long
Dim Cnt As Long
LastRow = Cells(Rows.Count, 1).End(xlUp).Row
'転記開始行
Cnt = 1
Application.ScreenUpdating = False
For i = 1 To LastRow
If Cells(i, 1) <> "" Then
'B列転記
Cells(Cnt, 2) = Cells(i, 1)
'転記開始行を更新
Cnt = Cnt + 1
End If
Next i
Application.ScreenUpdating = True
MsgBox "完了"
End Sub解説
まず、変数の宣言と、最終行を取得するためのコードが記述されています。変数iは、ループカウンタとして使用されます。LastRowは、列Aの最終行を表します。Cntは、データを書き込む行のインデックスとして使用されます。
次に、転記処理のためのコードが記述されています。転記開始行を1に設定し、データの書き込みにはCnt変数を使用します。ループは、列Aのすべての行に対して実行されます。列Aの値が空白でない場合は、その値を列Bに書き込みます。書き込みが完了したら、Cntを1増やし、次の行に書き込みます。最後に、Application.ScreenUpdatingプロパティを使用して画面の更新を停止し、処理が完了したことを示すメッセージボックスを表示します。
上記コードをスピードアップさせるために改善したコード
Sub 空白以外のセルを隣の列に転記２()
Dim i As Long
Dim LastRow As Long
Dim Cnt As Long
Dim ws As Worksheet
Dim data() As Variant
Set ws = ThisWorkbook.ActiveSheet
LastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
'転記対象の範囲をVariant型の配列に読み込む
data = ws.Range("A1:A" & LastRow).Value
'計算を一時停止して処理速度を向上
Application.Calculation = xlCalculationManual
For i = 1 To LastRow
If data(i, 1) <> "" Then
'B列に転記
ws.Cells(Cnt, 2).Value = data(i, 1)
'転記開始行を更新
Cnt = Cnt + 1
End If
Next i
'計算を再開する
Application.Calculation = xlCalculationAutomatic
MsgBox "完了"
MsgBox "完了"
End Sub解説
この改良版では、まずワークシート変数を使用して、処理対象となるワークシートを指定します。次に、RangeオブジェクトのValueプロパティを使用して、転記するデータを配列に読み込みます。これにより、Cells関数を使用することなく、ワークシートのセルへのアクセスを最小限に抑えることができます。
また、Application.CalculationプロパティをFalseに設定することで、Excelの自動計算機能を一時的に無効にすることができます。これにより、転記作業中の自動計算による処理速度の低下を防止することができます。最後に、再びApplication.CalculationプロパティをTrueに設定して、Excelの自動計算機能を再開します。
この改良版では、ワークシート変数を使用することにより、ワークシートのアクセス回数を減らし、配列を使用することにより、一度に多くのデータを処理することができます。また、Application.Calculationプロパティを使用して、計算を一時停止することにより、処理速度を向上させることができます。
コメント