VBAでのデータ転記処理

質問

下記の処理をVBAで作成したいのですが…。

Book "aaa" の "Sheet1"

A ｜B ｜C ｜D ｜E ｜F ｜G ｜H ｜I ｜J ｜K
1 あ｜い｜う｜え｜お｜か｜き｜く｜け｜こ｜さ
2 た｜ち｜つ｜て｜と｜な｜に｜ぬ｜ね｜の｜は｜ひ｜ふ｜へ
3 ま｜み｜む｜め｜も｜や｜ゆ｜よ

これをBook "bbb" の "Sheet1" に

A｜B｜C｜D｜E
1 あ｜い｜う｜え｜お
2 か｜き｜く
3 け｜こ｜さ
4
5 た｜ち｜つ｜て｜と
6 な｜に｜ぬ
7 ね｜の｜は
8 ひ｜ふ｜へ
9
10 ま｜み｜む｜め｜も
11 や｜ゆ｜よ

と言う風にデータを転記したいのです。

Book "aaa" の Sheet "Sheet1"のＡ～Ｅ列までは必ずデータが入っていますが
Ｆ列以降は、データがある場合と無い場合があり
データがなければ、そこのセル（行）は詰める。

さらに、Book "aaa" の１行を１セットとして、Book "bbb" で１セット単位で、空白行を設けたいのです。
上記例のように、１セットの行数は固定ではありません。

Book "aaa" の Sheet "Sheet1"のデータ行数は大量に（1000行以上）あります。

わかりにくいと思いますが、どなたかよろしく御願いします。

回答No.1

Wendy02 · ベストアンサー

こんにちは。

ちょっとまとめますと、

**
元のブック(aaa.xls)のSheet1 の1行ごとのデータを、セルの間をおかずに、

別のブック(bbb.xls)のSheet1 に、A1から順に
最初の行に－５セル
次の行以降は－３セルずつ
元のシートの行が変わるときには、１行間を空けて
元のブックの行順に繰り返し、コピーする。
**

ということになるのでしょうか？
一応、ブックは既に両方とも開いているものとします。最初、少量のサンプルからお試しください。

'<標準モジュール>
Sub Sample()
　Dim i As Long, j As Long, m As Long, n As Long
'ソース側
　Application.Goto Workbooks("aaa.xls"). _
　Worksheets("Sheet1").Range("A1")
　'コピー側
　With Workbooks("bbb.xls").Worksheets("Sheet1")
　　Application.ScreenUpdating = False
　　n = 1: m = 1
　　For i = 1 To Cells(65536, 1).End(xlUp).Row
　　　For j = 1 To Cells(i, 256).End(xlToLeft).Column
　　　　If Not IsEmpty(Cells(i, j)) Then
　　　　　If j < 6 Then
　　　　　　.Cells(n, m).Value = Cells(i, j).Value
　　　　　　m = m + 1
　　　　　　Else
　　　　　　If m >= 3 Then
　　　　　　　n = n + 1: m = 1
　　　　　　　Else
　　　　　　　m = m + 1
　　　　　　End If
　　　　　　.Cells(n, m).Value = Cells(i, j).Value
　　　　　End If
　　　　End If
　　　Next j
　　　n = n + 2: m = 1
　　Next i
　　Application.ScreenUpdating = True
　End With
End Sub

補足

Wendy02さん！素早く、しかも的確なご回答ありがとうございました！

実際の項目数にアレンジし直して使用させて頂きましたが、ビックリするくらいスッキリ仕上がりました。
いとも簡単にこんなコードを書いてしまわれるのには、感服致します。（私が知らなさすぎ？！）

この上、欲張りを言って申し訳ないのですが
コピー側の２行目（元データの６項目以降）の貼り付け位置を下記のようにすることは可能でしょうか？

｜ A ｜B ｜C ｜D ｜E ｜F｜G｜H
1｜あ｜い｜う｜え｜お
2｜ ｜ ｜ ｜か｜ ｜き｜ ｜く

2行目以降はＤ列から貼り付け、且つ１セルずつあける。

教えて頂いた

Else
　If m >= 3 Then
　　　n = n + 1: m = 1

の「m=1」を「m=4」に変えてみたりしたのですが
そうすると、「か」「き」「く」が「D1」「D2」「D3」に入ってしまいました。 (^_^!)

ド素人で申し訳ありません。

もしお時間よろしければ、ご教授御願い致します。

回答No.4

imogasi

短くならないかと考えて
Sub test07()
Dim sh1 As Worksheet
Dim sh2 As Worksheet
Set sh1 = Worksheets("sheet4")
Set sh2 = Worksheets("sheet5")
d = sh1.Range("a65536").End(xlUp).Row
k = 1
For i = 1 To d
'---
For j = 1 To 5
sh2.Cells(k, j) = sh1.Cells(i, j)
Next j
k = k + 1
'---
For m = 6 To 50 Step 3
If sh1.Cells(i, m) = "" Then
k = k + 1
Exit For
Else
sh2.Cells(k, 1) = sh1.Cells(i, m)
sh2.Cells(k, 2) = sh1.Cells(i, m + 1)
sh2.Cells(k, 3) = sh1.Cells(i, m + 2)
k = k + 1
End If
Next m
Next i
End Sub
同一ブックの２シートでやって、テストの手を抜いてます。
他のご回答など見て修正してください。
For m = 6 To 50 Step 3の５０は最右列を見積もって変えてください。
質問例ではテスト済み。

お礼

お返事が遅くなり、申し訳ありませんでした！
早速ご回答下さり、ありがとうございました。

皆さんに教えて頂いた物を部分的に使わせて頂いて
なんとか、作成したい表にすることができました！

回答No.3

Wendy02

こんばんは。 Wendy02です。

お目にとまり、ありがとうございます。

＞2行目以降はＤ列から貼り付け、且つ１セルずつあける。
＞　　　n = n + 1: m = 1

＞の「m=1」を「m=4」に変えてみたりしたのですが

着目点は良かったのですが、増加する部分ですから、増加する数を修正しないといけないわけです。これも数列ですね。

下から9行目の

修正前　　.Cells(n, m).Value = Cells(i, j).Value
　　　　　　　　　　　↓
修正後:
　　.Cells(n, (m * 2) + 2).Value = Cells(i, j).Value

とすればよいです。

お礼

何から何までありがとうございました。
とても役に立ちました！

お礼が遅くなり、申し訳ありませんでした。

回答No.2

tona-tona

こんにちは。
VBAを半年振りに再開した初級者くらいです。
参考程度にしてください。
動作確認：Excel97

10000×5（8）の配列に入れてっているので、
出来あがる表が1万行を超えるとエラーがでます。
その辺は工夫して直して下さいね。

最初の質問のはこんな感じで。

Sub aaaとbbbを開いてから実行してね001()

Dim Sh0 As Worksheet
Dim Sh1 As Worksheet
Dim ShName As String
Dim ShName0 As String
Dim I As Long
Dim M As Long
Dim N As Long
Dim R1 As Long
Dim C1 As Long

Dim Arr0 As Variant
Dim Arr1(1 To 10000, 1 To 5) As Variant

Application.ScreenUpdating = False

Set Sh0 = Workbooks("aaa.xls").Sheets("Sheet1")
Set Sh1 = Workbooks("bbb.xls").Sheets("Sheet1")

M = 0

Arr0 = Sh0.Cells(1).CurrentRegion.Value

For R1 = 1 To UBound(Arr0, 1)
N = 0
For C1 = 1 To UBound(Arr0, 2)
If Arr0(R1, C1) = Empty Then Exit For
Select Case C1
Case 1 To 5
If C1 = 1 Then M = M + 1
N = C1
Case Is >= 6
If (C1 Mod 3) = 0 Then M = M + 1
N = (C1 Mod 3) + 1
End Select
Arr1(M, N) = Arr0(R1, C1)
Next C1
M = M + 1
Next R1

Sh1.Cells(1, 1).Resize(M, 5).Value = Arr1
Erase Arr0
Erase Arr1

Application.ScreenUpdating = True

End Sub

補足後はこんな感じ。

Sub aaaとbbbを開いてから実行してね002()

Dim Sh0 As Worksheet
Dim Sh1 As Worksheet
Dim ShName As String
Dim ShName0 As String
Dim I As Long
Dim M As Long
Dim N As Long
Dim R1 As Long
Dim C1 As Long

Dim Arr0 As Variant
Dim Arr1(1 To 10000, 1 To 8) As Variant

Application.ScreenUpdating = False

Set Sh0 = Workbooks("aaa.xls").Sheets("Sheet1")
Set Sh1 = Workbooks("bbb.xls").Sheets("Sheet1")

M = 0

Arr0 = Sh0.Cells(1).CurrentRegion.Value

For R1 = 1 To UBound(Arr0, 1)
N = 0
For C1 = 1 To UBound(Arr0, 2)
If Arr0(R1, C1) = Empty Then Exit For
Select Case C1
Case 1 To 5
If C1 = 1 Then M = M + 1
N = C1
Case Is >= 6
If (C1 Mod 3) = 0 Then M = M + 1
N = 4 + (C1 Mod 3) * 2 'ここを変更
End Select
Arr1(M, N) = Arr0(R1, C1)
Next C1
M = M + 1
Next R1

Sh1.Cells(1, 1).Resize(M, 8).Value = Arr1　'ここを変更
Erase Arr0
Erase Arr1

Application.ScreenUpdating = True

End Sub

お礼

お返事が遅くなり、申し訳ありませんでした！
早速ご回答下さり、ありがとうございました。

皆さんに教えて頂いた物を部分的に使わせて頂いて
なんとか、作成したい表にすることができました！