A列のデータに合わせてB:Gにあるデータを並べる。

質問

写真の黄色部分のデータを緑の部分の様に変更するためにはどんなVBAを書けばよいか全くアイデアが浮かびません。なにか良いアイデアがあればよろしくお願いします。写真が一枚しかアップできなかったので便宜的に２つのデータを並べましたが黄色から緑に変更です。行、列番号も便宜的に手入力ですが普通の行列番号との前提で、

回答No.6

HohoPapa

#4です。
今更ですが、
SQL文の一部に全角スペースが混じっているので
直して再ポストします。

直している個所は以下です。
修正前
　SQL = SQL & "Left join　[Sheet1$B1:Z65000] as T2 on " & vbCrLf
修正後
　SQL = SQL & "Left join [Sheet1$B1:Z65000] as T2 on " & vbCrLf

Option Explicit

Sub Sample()

　Dim SQL As String
　Dim cn As Object
　Dim rs As Object
　Set cn = CreateObject("ADODB.Connection")
　Set rs = CreateObject("ADODB.Recordset")
　cn.Provider = "Microsoft.ACE.OLEDB.12.0"
　cn.Properties("Extended Properties") = "Excel 12.0;HDR=YES;IMEX=1"
　cn.Open ThisWorkbook.FullName

　SQL = ""
　SQL = SQL & "select T1.勤務地1,T2.勤務地2,T2.Ａ,T2.Ｂ,T2.Ｃ,T2.Ｄ" & vbCrLf
　SQL = SQL & "FROM [Sheet1$A1:A65000] as T1" & vbCrLf
　SQL = SQL & "Left join [Sheet1$B1:Z65000] as T2 on " & vbCrLf
　SQL = SQL & "T1.勤務地1=T2.勤務地2 " & vbCrLf

　rs.Open SQL, cn

　With ThisWorkbook.Worksheets("Sheet3")
　　.Cells.ClearContents
　　ThisWorkbook.Sheets("Sheet1").Range("A1:F1").Copy .Range("A1")
　　.Range("A2").CopyFromRecordset rs
　End With

End Sub

回答No.5

kon555

>>ちょっと難しいですが、少し時間をとって
配列はほんの少し複雑ですが、VBAの基本である変数のちょっと拡大版にすぎません。その割りにデータ整理・データ整形では便利に使えるものなので、これを機にマスターするつもりで頑張ってみて下さい。
細かな構文などは検索すればいくらでも出てくるので「配列という形」を理解するのを優先するのがいいと思います。

なので、ちょっとVBA云々というよりも「配列ってなんぞや」という概念理解の参考ページを貼っておきます。ご参考まで。
https://wa3.i-3-i.info/word11924.html

回答No.4

HohoPapa

VBAでの解をお求めですが、
期待のことはVBAを使うことなく、関数式でも可能です。
また、VBAで処理するのであれば、
若干ハードルが高くなりますが、VBA+SQLで実現する方法があります。

まずは、前者から説明します。

変換元がSheet1、変換先がSheet2だとすれば、
Sheet2
A1=Sheet1!A1　の計算式を埋め
これを横方向と下方向に必要数複写します。
続いて、
B2=IFNA(INDEX(Sheet1!$B$1:$F$13,MATCH($A2,Sheet1!$B$1:$B$13,0),COLUMN()-1),"")
これを、必要な範囲に（つまりF13まで複写します。

続いて後者を説明します。

変換元がSheet1、変換先がSheet3と仮定して．．．
提示されたサンプル画面はSheet1のA1,B1セルが同じ文字列に見えます。
同じだとちょっと具合が悪いので、便宜的に
A1=勤務地1
B1=勤務地2　とします。
これなら、次のコードで期待のことができます。

Option Explicit

Sub Sample()

　Dim SQL As String
　Dim cn As Object
　Dim rs As Object
　Set cn = CreateObject("ADODB.Connection")
　Set rs = CreateObject("ADODB.Recordset")
　cn.Provider = "Microsoft.ACE.OLEDB.12.0"
　cn.Properties("Extended Properties") = "Excel 12.0;HDR=YES;IMEX=1"
　cn.Open ThisWorkbook.FullName

　SQL = ""
　SQL = SQL & "select T1.勤務地1,T2.勤務地2,T2.Ａ,T2.Ｂ,T2.Ｃ,T2.Ｄ" & vbCrLf
　SQL = SQL & "FROM [Sheet1$A1:A65000] as T1" & vbCrLf
　SQL = SQL & "Left join　[Sheet1$B1:Z65000] as T2 on " & vbCrLf
　SQL = SQL & "T1.勤務地1=T2.勤務地2 " & vbCrLf

　rs.Open SQL, cn

　With ThisWorkbook.Worksheets("Sheet3")
　　.Cells.ClearContents
　　ThisWorkbook.Sheets("Sheet1").Range("A1:F1").Copy .Range("A1")
　　.Range("A2").CopyFromRecordset rs
　End With

End Sub

回答No.3

kon555

説明用サンプルとしてのデータでしょうし、既に回答がついているので具体的なコードは書きませんが、ソートしたい対象の範囲(例示データでいえばB2～F13)を一旦配列に取り込んでしまうのが良いと思います。

今回書かれている内容の場合、要はBからFの一行が一連のデータになっているので、配列としては非常にシンプルです。
またそうして取り込んだデータの先頭要素とA列が一致するかどうかの判定も、if文で簡単に実装できます。
参考URLを置いておくのでご参考に。

https://www.excelspeedup.com/vbaarray/
http://officetanaka.net/excel/vba/variable/08.htm

ただ、こうした作業をマクロ化する際に注意しなければならないのは「どこまで想定するか」です。
　例えば貴方の手元に来るデータは必ずA-Fの列範囲なのか？　増減はないのか？　ソート対象のデータには、目印であるA列に存在しないデータは混ざらないのか？　データの誤字等は想定しないのか？　・・・等々。
　そうした点を考慮していけば、実務で使用しやすいマクロが作れると思います。頑張って下さい。

お礼

いただいたURLが参考になりそうです。VBA初心者の私にはちょっと難しいですが、少し時間をとってじっくり考えてみます。またわからないことがあればよろしくお願いします。

回答No.2

watabe007

参考に
Sub Test()
　　Dim i As Long, j As Long
　　Dim V(1 To 12, 1 To 5), myR As Variant
　　For i = 2 To Cells(Rows.Count, "B").End(xlUp).Row
　　　　myR = Application.Match(Cells(i, "B").Value, Columns(1), 0)
　　　　If Not IsError(myR) Then
　　　　　　For j = 1 To 5
　　　　　　　　V(myR - 1, j) = Cells(i, j + 1).Value
　　　　　　Next
　　　　Else
　　　　　　MsgBox Cells(i, "B").Value & " がＡ列に登録されていません。"
　　　　　　Exit Sub
　　　　End If
　　Next
　　Range("B2:F13").Value = V
End Sub

回答No.1

nishi6

A列とB列を合わせると理解してセルを挿入しています。
勤務先名の２つのセル番地(strTop1、strTop2)、挿入する列数(columnNum)は実際のデータに合うように入力してください。
当方、win10、Excel2010です。

Sub DataSet()
　Dim strTop1 As String　　'// 勤務地名(左)の表題アドレス
　Dim strTop2 As String　　'// 勤務地名(右)の表題アドレス
　Dim rw1 As Integer　　　 '// 行カウンタ1
　Dim rw2 As Integer　　　 '// 行カウンタ22
　Const columnNum = 6　　　'// B～G列の列数()
　strTop1 = "A1"
　strTop2 = "B1"

　rw1 = 1: rw2 = 1
　With ActiveSheet.Range(strTop2)
　　While .Offset(rw2, 0) <> ""
　　　'// B列とA列を比べる
　　　rw1 = 0
　　　While .Offset(rw2, 0) <> .Offset(rw2 + rw1, -1)
　　　　rw1 = rw1 + 1
　　　Wend

　　　'// B列とA列の差分の行を挿入する
　　　If rw1 > 0 Then
　　　　Range(.Offset(rw2, 0), .Offset(rw2, columnNum - 1)).Select
　　　　Selection.Insert Shift:=xlDown
　　　End If

　　　rw2 = rw2 + 1
　　Wend
　End With
End Sub