VBAを使用した表の転記

質問

VBA超初心者です。表を新たな別ブックのシートに転記した上、「商品名～住所」単位で行の下に一行追加した上で「商品名2～住所2」単位でセルを上のセルより切り取って貼り付け、セルにデータのないときは飛ばしてデータのあるセルに同じ処理をしたいと考えております。
よい方法があれば教えていただけますか。

回答No.6

kkkkkm

新規ブックを現在のブック名の頭に「New_」を付けて現在のブックと同じフォルダにxlsxファイルとして保存して利用します。

ワンブロック7列なので毎回7列一度に転記しています。
元のシート名はSheet1にしてますから適宜変更してください。2か所あります。

Sub Test()
Dim i As Long, j As Long, BlockCount As Long
Dim FirstRow As Long, LastRow As Long, Ws2LastRow As Long, tmp As Long
Dim Wb As Workbook
Dim Ws1 As Worksheet, Ws2 As Worksheet

ThisWorkbook.Sheets("Sheet1").Copy
ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Path & _
"\New_" & Left(ThisWorkbook.Name, InStrRev(ThisWorkbook.Name, ".")) & "xlsx"
Set Wb = ActiveWorkbook
Set Ws2 = Wb.Worksheets.Add
Ws2.Name = "転記後"
Set Ws1 = Wb.Sheets("Sheet1")

FirstRow = 2
LastRow = 1
BlockCount = 7

''完全に空白の行が途中に無い場合
''たとえば質問の画像で2行目にデータが全然無いなどが無い場合こちらを有効に
'LastRow = Ws1.Range("A1").CurrentRegion(Ws1.Range("A1").CurrentRegion.Count).Row

'完全に空白の行が途中にある可能性が存在する場合 現在の処理
For i = Columns("A:A").Column To Columns("U:U").Column
tmp = Ws1.Cells(Rows.Count, i).End(xlUp).Row
If tmp > LastRow Then
LastRow = tmp
End If
Next

Ws2LastRow = 1
For j = FirstRow To LastRow
For i = Columns("A:A").Column To Columns("U:U").Column Step BlockCount
Ws2.Cells(Ws2LastRow, "A").Resize(1, BlockCount).Value = Ws1.Cells(j, i).Resize(1, BlockCount).Value
Ws2LastRow = Ws2LastRow + 1
Next
Next

Wb.Save

End Sub

お礼

本当に助かりました。ありがとうございます。

回答No.5

putitdevil

質問者さんがVBA初心者の方ということですので
for文を何度も入れ子（ネスト）にするものではなく
シンプルなものにしてみました

'Sheet1にコード記述
Sub testCode()

'読み込み開始行
Dim rRow As Integer: rRow = 2
'書き込み開始行
Dim wRow As Integer: wRow = 20
'商品データ読込回数
Dim kaisuu As Integer: kaisuu = 3

'指定回数繰り返し
For i = 0 To kaisuu - 1
'商品名１の転記処理
Range(Cells(wRow, 1), Cells(wRow, 7)) = Range(Cells(rRow, 1), Cells(rRow, 7)).Value
'商品名２の転記処理
Range(Cells(wRow + 1, 1), Cells(wRow + 1, 7)) = Range(Cells(rRow, 8), Cells(rRow, 14)).Value
'商品名３の転記処理
Range(Cells(wRow + 2, 1), Cells(wRow + 2, 7)) = Range(Cells(rRow, 15), Cells(rRow, 21)).Value

rRow = rRow + 1: wRow = wRow + 3
Next

End Sub

回答No.4

imogasi

この質問は、「表の組み換え｝というタイプの課題だ。
関数でも複雑になり、操作でも、エクセルでは、良いものが備わってない。エクセルの盲点かと思う。
だからVBAでやりたくなる。
ーー
質問のデータ例の第１行目の商品名1,2,3にあたる数は３商品以下なのか？
こういう制約数を質問に明記するのが、回答を簡単にし、かつ即応用できる回答になるポイントだ。
ーー
初歩的なロジックに徹するため、
・各行について、全行総当たりするので、行ポインターを i とする。
・完成形のシートは別シートに作る方がよい。すると、データを指定するセルが、大きく分けて、別シートの２か所になる。
このVBAでの指定する記法は、シート名＋セル番地という書き方になる。コードでは、＋はドットで区切る。
別ブックにアウトプットは指定はWEBで照会してください。
Shheet2のアウトプットの行ポインターは k とする。
ーー
列的には、７列使って、１商品データを模擬方向に並べているので、列数的に、Fot　NextのStep 7
Ｆｏｒ　ｊ=１ to 50 Step 7
という飛び飛びの繰り返しを使う。
その７列ｘ整数倍目が、空白ならその行のデータ終りだ、とみなす。
＝＝＝＝
Sub test01()
最終行番号=100 ' テスト時は５ぐらいにして、適宜変えること
For i = 2 To 　最終行番号
If Worksheets("Sheet1").Cells(i, 1) = "" Then GoTo p2 'その行のA冽空白かあああああ・
For j = 1 To 50 Step 7
If Worksheets("Sheet1").Cells(i, j) = "" Then GoTo p1
MsgBox Cells(i, j)
Next j
p1:
Next i
p2:
End Sub
で商品名を捉えているかテストする。
ーー
次にSheet2を考えて。このＳｈｅｅｔ１のデータを持って行く先のシートの行番号をｋ（役割的には、ポインター）で管理する。
ｌで１製品７セルある列を指し示す。
＝＝＝＝＝
標準モジュールに
Sub test01()
k = 2
For i = 2 To 3
If Worksheets("Sheet1").Cells(i, 1) = "" Then GoTo p2 'その行のA冽空白か
For j = 1 To 50 Step 7
If Worksheets("Sheet1").Cells(i, j) = "" Then GoTo p1
MsgBox Worksheets("Sheet1").Cells(i, j)
'---
For l = 1 To 7
Worksheets("Sheet2").Cells(k, l) = Worksheets("Sheet1").Cells(i, j + l - 1)
Next l
k = k + 1
'--
Next j
p1:
Next i
p2:
End Sub
＝＝＝
ＶＢＡのベテランには笑われますが、
ワザと、変数定義などは省略してある。
Ｇｏｔｏ文も避けるのが普通だが、あえて使用した。
最終行番号のVBAでの取得も省略した。WEBで「VBA　データ最終行番号」照会のこと。
ーーー
Ｆｏｒ　Ｎｅｘｔの応用は非常に広いです。シートのセルを対象にするＶＢＡでは、これから使い始めてはどうか。

回答No.3

SI299792

関数でも可能です。３列限定ですが数式を変更すればもっと多い列でもできます。
VBA の方がよければ無視して下さい。
上画像：Sheet1とします。

下画像：Sheet2とします。
H1: =IF(INDEX(Sheet1!A:O,ROW(H3)/3+1,MOD(ROW(H3),3)*7+1)<>"",ROW()-1)
下へコピペ。ワークエリアです。空白を含めたデータ件数分必要です（画像の場合９行以下迄）。目障りなら非表示にして下さい。
A2: =IFERROR(INDEX(Sheet1!A:O,SMALL($H:$H,ROW()-1)/3+2,MOD(SMALL($H:$H,ROW()-1),3)*7+1),"")
右下へコピペ。

回答No.2

HohoPapa

転記元が１シート目、転記先シートが２シート目なら
後記コードでいかがでしょうか？

Sub sample()
　Const GetSRow = 2 '元データの開始行番号
　Const GetERow = 4 '元データの終了行番号

　Dim ShGet As Worksheet
　Dim ShPut As Worksheet
　Dim i As Long
　Dim j As Long
　Dim r As Long
　Dim PutR As Long

　Set ShGet = ThisWorkbook.Sheets(1)
　Set ShPut = ThisWorkbook.Sheets(2)

　PutR = 0
　For r = GetSRow To GetERow
　　For i = 0 To 2
　　　PutR = PutR + 1
　　　For j = 1 To 7
　　　　ShPut.Cells(PutR, j).Value = _
　　　　　ShGet.Cells(r, i * 7 + j).Value
　　　Next j
　　Next i
　Next r

End Sub

回答No.1

Ultra-Hetare

要件は
・決まった行数のデータが、決まった列数あり。
　現状、ひとかたまり単位で横方向に並んでいる。
・これをそのデータ単位で縦方向に並べ替えたい。

ということでしょうか？

データの行数プラス1のセルにデータの列数プラス1の内容を
切り取って貼り付けるだけで出来ると思いますが、
詳細が不明ですのでコードを書くことは出来ません。

補足

説明不足で申し訳ございません、その認識で合っています。