エクセルvbaについて

質問

いまある表を作成して降ります。
その表を別シートに作成したセルに必要な部分のみ転記したいと思っておあります。
表1

No 日付　顧客名　請求金額　立替金　非課税　課税
1　　01　　A社　　　2010　　1500　　 300　　 210
2　　04　　B社　　　5100　　2000　　1000　 2100
3 05 C社　　 10200 6000 0 4200
↓

別表

No
1 2010 A社　　請求金額　　01
1 1500　 A社　　立替金　　　01
1 300 A社　　課税　　　　01
1 210 A社 　非課税　　　01
2 5100 B社　　　↓　　　　02
2 2000 B社　　　　　　　　02
2 1000 B社　　　　　　　　02
2 2100 B社　　　　　　　　02
3 10200 C社　　　　　　　　↓
3 6000 C社　
3 0 C社
3 4200 C社

と必ず４項目なのですが、最終的に0円の行を削除して完成になります。
上記の表ですと　3番に0円がありますので最終的に削除します。
顧客名も４項目づつ入ります。
この作業を一連のマクロにて実施したいのですが、可能でしょうか？
よろしくおねがいいたします。

回答No.4

big_fool · ベストアンサー

Sub TEST()
Dim A As Long
Dim B As Long
Dim C As Long
Dim D As Long
Dim E As Long
Dim F As Long

'表の行数を調べる
A = Worksheets("sheet1").Range("A1").CurrentRegion.Rows.Count - 1

For C = 0 To A

For B = 4 To 7
'Sheet1のデータをSheet2に複写する
Worksheets("Sheet2").Cells(B - 3 + D, 1) = Worksheets("Sheet1").Cells(C + 1, 1)
Worksheets("Sheet2").Cells(B - 3 + D, 2) = Worksheets("Sheet1").Cells(C + 1, B)
Worksheets("Sheet2").Cells(B - 3 + D, 3) = Worksheets("Sheet1").Cells(C + 1, 3)
Worksheets("Sheet2").Cells(B - 3 + D, 4) = Worksheets("Sheet1").Cells(1, B)
Worksheets("Sheet2").Cells(B - 3 + D, 5) = Worksheets("Sheet1").Cells(C + 1, 2)

Next
D = C * 4
Next
'Sheet2の表の行数を調べる
Sheets("Sheet2").Select
E = Worksheets("sheet2").Range("A1").CurrentRegion.Rows.Count

'非課税欄の確認
For F = 1 To E
If Worksheets("Sheet2").Cells(F, 2) = 0 Then
'0の場合は行を削除する
Cells(F, 1).EntireRow.Delete
End If
Next

End Sub

単純にこのように考えて見ましたあまりよい見本とはいえませんね
削除のループは一緒に出来なかったので最後に書いて見ましたあまり時間がなかったのでこんなもんで失礼します

お礼

ありがとうございました。何とかなりそうですが、不明な点がいくつかあります。

補足

ありがとうございます。教えてください。
いま勉強しながらやっていますが、いまいちわかりません。
For C = 0 To A

For B = 4 To 7
'Sheet1のデータをSheet2に複写する
Worksheets("Sheet2").Cells(B - 3 + D, 1) = Worksheets("Sheet1").Cells(C + 1, 1)
Worksheets("Sheet2").Cells(B - 3 + D, 2) = Worksheets("Sheet1").Cells(C + 1, B)
Worksheets("Sheet2").Cells(B - 3 + D, 3) = Worksheets("Sheet1").Cells(C + 1, 3)
Worksheets("Sheet2").Cells(B - 3 + D, 4) = Worksheets("Sheet1").Cells(1, B)
Worksheets("Sheet2").Cells(B - 3 + D, 5) = Worksheets("Sheet1").Cells(C + 1, 2)

Next
D = C * 4
Next
でシート１の２行目から転写開始しますが、シート２
のセル（1,1)からになるのかが不明です。

回答No.6

imogasi

この問題は、直線的な繰り返しの問題で、何もむつかしくないですよ。
表Aの最終行を知る。Dとする。
（＊）表Aについて
表Aのある行(i)に付き
その行はDに等しいか。等しければ終り。
請求金額０円なら次のブロックへ
表BのJ行のA列＝請求金額（C列）
表BのJ行のB列＝社名（B列）
表BのJ行のC列＝請求金額と言う文字列
表BのJ行のD列＝日付け（A列）
立替金額０円なら次のブロックへ
J=J+1
表BのJ行のA列＝立替金額（D）
表BのJ行のB列＝社名（B列）
表BのJ行のC列＝立替金と言う文字列
表BのJ行のD列＝日付け（A列）
課税金額０円なら次のブロックへ
J=J+1
表BのJ行のA列＝課税額（D）
表BのJ行のB列＝社名（B列）
表BのJ行のC列＝課税と言う文字列
表BのJ行のD列＝日付け（A列）
非課税金額０円なら次のブロックへ
J=J+1
表BのJ行のA列＝非課税額（D）
表BのJ行のB列＝社名（B列）
表BのJ行のC列＝非課税と言う文字列
表BのJ行のD列＝日付け（A列）
i=i+1
繰り返し（＊）へ
右辺はすべてA表のセル。
あと道具立ては
・A,B表の表現のし方
・セルはSH1.Cells(i,"A")のように表す。
・最下行はCurrentRegionかSh1.Range("A65536").End(xlUP)などで知る。
行をDeleteするより、書かないほうが良いと思う。

回答No.5

big_fool

2回も投稿してしまいすみません

回答No.3

big_fool

Sub TEST()
Dim A As Long
Dim B As Long
Dim C As Long
Dim D As Long
Dim E As Long
Dim F As Long

'表の行数を調べる
A = Worksheets("sheet1").Range("A1").CurrentRegion.Rows.Count - 1

For C = 0 To A

For B = 4 To 7
'Sheet1のデータをSheet2に複写する
Worksheets("Sheet2").Cells(B - 3 + D, 1) = Worksheets("Sheet1").Cells(C + 1, 1)
Worksheets("Sheet2").Cells(B - 3 + D, 2) = Worksheets("Sheet1").Cells(C + 1, B)
Worksheets("Sheet2").Cells(B - 3 + D, 3) = Worksheets("Sheet1").Cells(C + 1, 3)
Worksheets("Sheet2").Cells(B - 3 + D, 4) = Worksheets("Sheet1").Cells(1, B)
Worksheets("Sheet2").Cells(B - 3 + D, 5) = Worksheets("Sheet1").Cells(C + 1, 2)

Next
D = C * 4
Next
'Sheet2の表の行数を調べる
Sheets("Sheet2").Select
E = Worksheets("sheet2").Range("A1").CurrentRegion.Rows.Count

'非課税欄の確認
For F = 1 To E
If Worksheets("Sheet2").Cells(F, 2) = 0 Then
'0の場合は行を削除する
Cells(F, 1).EntireRow.Delete
End If
Next

End Sub

単純にこのように考えて見ましたあまりよい見本とはいえませんね
削除のループは一緒に出来なかったので最後に書いて見ました

回答No.2

taocat

なかなか回答がつかないですねぇ。
で、簡単なサンプルをひとつ。

Sheet1：表
Sheet2：別表

表、別表も１行目は見出しとする。

Sub test()
Dim R1 As Long
Dim R2 As Long
Dim C1 As Integer
Dim Sht2 As Worksheet

Set Sht2 = Worksheets("Sheet2")
R2 = 1

With Worksheets("Sheet1")
For R1 = 2 To .Range("A65536").End(xlUp).Row
For C1 = 4 To 7
If .Cells(R1, C1) <> 0 Then
R2 = R2 + 1
Sht2.Range("A" & R2) = .Cells(R1, 1)
Sht2.Range("B" & R2) = .Cells(R1, C1)
Sht2.Range("C" & R2) = .Cells(R1, 3)
Sht2.Range("D" & R2) = .Cells(1, C1)
End If
Next C1
Next R1
End With
End Sub

実際は最初に別表の結果を削除するとか、別表の見出しをセットするとかのコードがいりますが、詳しいことがわからないし、サンプルということで省いてありますので、テストを繰り返す場合は、別表結果を削除してから実行してくだされ。

それから、値０の項目は別表が出来てからではなくて、最初から省いてありまする。
以上。

回答No.1

noname#8185

if文で書かなくすればよいのでは