こんにちは。
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
補足
Wendy02さん!素早く、しかも的確なご回答ありがとうございました! 実際の項目数にアレンジし直して使用させて頂きましたが、ビックリするくらいスッキリ仕上がりました。 いとも簡単にこんなコードを書いてしまわれるのには、感服致します。(私が知らなさすぎ?!) この上、欲張りを言って申し訳ないのですが コピー側の2行目(元データの6項目以降)の貼り付け位置を下記のようにすることは可能でしょうか? | A |B |C |D |E |F|G|H 1|あ|い|う|え|お 2| | | |か| |き| |く 2行目以降はD列から貼り付け、且つ1セルずつあける。 教えて頂いた Else If m >= 3 Then n = n + 1: m = 1 の「m=1」を「m=4」に変えてみたりしたのですが そうすると、「か」「き」「く」が「D1」「D2」「D3」に入ってしまいました。 (^_^!) ド素人で申し訳ありません。 もしお時間よろしければ、ご教授御願い致します。