EXCELマクロによる繰り返し転記方法について

添付画像の様に、入力シートがあり、その中で項目のチェックが丸のものを転記シートに転記したいと考えています。チェックが×のものは一切転記せず、丸のものは開始から終了まで同じ金額コードを繰り返し、１つ終われば次の情報を同じように転記をします。作られたマクロを少し修正したことはありますが、１から作ったことが無く、どのように作ればよいか教えていただければ助かります。

No.3 回答者： hiro40199210 回答日時： 2016/08/01 15:14

オートフィルターで○のデータを抽出して、追加したシートにペーストします。

追加するシート名を「転記」にしますので、既に「転記」というシートが存在していたらエラーになります。
元データのあるシートをアクティブにして実行してください。

Sub ○のみ抽出()
Dim SH
Set SH = ActiveSheet
With Range("a1")
If .AutoFilter = False Then
.AutoFilter
End If

.AutoFilter field:=2, Criteria1:="○"
.CurrentRegion.Copy
End With

Sheets.Add

With Range("a1")
.PasteSpecial xlPasteColumnWidths
.PasteSpecial xlPasteFormats
.PasteSpecial xlPasteValues
End With

Range("b1,e1,g1").EntireColumn.Delete
Cells(1, 4) = "年月"
ActiveSheet.Name = "転記"
SH.Range("A1").AutoFilter
End Sub

No.2 回答者： tom04 回答日時： 2016/07/30 21:27

こんばんは！

一例です。
前提条件として、「入力シート」の配置は↓の画像のようになっていて、
F列はシリアル値が入り、表示形式がユーザー定義の
ge.m
となっているという前提です。
標準モジュールです。

Sub Sample1()
Dim i As Long, cnt As Long, lastRow As Long, wS As Worksheet
Set wS = Worksheets("入力シート")
With Worksheets("転記シート")
lastRow = .Cells(Rows.Count, "A").End(xlUp).Row
If lastRow > 1 Then
Range(.Cells(2, "A"), .Cells(lastRow, "D")).ClearContents
End If
For i = 2 To wS.Cells(Rows.Count, "A").End(xlUp).Row
If wS.Cells(i, "B") = "○" Then
Do
cnt = cnt + 1
With .Cells(Rows.Count, "A").End(xlUp).Offset(1)
.Value = wS.Cells(i, "A")
.Offset(, 1) = wS.Cells(i, "C")
.Offset(, 2) = wS.Cells(i, "D")
With .Offset(, 3)
.Value = DateAdd("m", cnt - 1, wS.Cells(i, "F"))
.NumberFormatLocal = "ge.m"
End With
End With
If cnt = wS.Cells(i, "E") Then Exit Do
Loop
cnt = 0
End If
Next i
End With
End Sub

こんな感じではどうでしょうか？m(_ _)m

No.1 回答者： WindFaller 回答日時： 2016/07/30 21:07

こんばんは。

>１から作ったことが無く、どのように作ればよいか教えていただければ助かります

1から作るつもりなら、ある程度は応援しますが、あまり人には頼らないほうがよいと思います。依頼心が湧くと上達しません。

最初は、記録マクロを組み入れながら、作っていくという方法が多いのですが、私のであった人の中には、もう完成したフローチャートが出来上がっていた人がいました。マクロの経験もないということでしたから、その人は天才だと思いました。何百人に一人、そういう人はいらっしゃるようです。一人は、当時大学の語学の講師で今は大学教授かと思います。もう一人は、ここの掲示板で出会った人です。
アルゴリズムに必要なパーツさえ、そろえばよいのですから、意外に早く出来上がりますし、仕上げの段階で、掲示板できけば、すぐにも人は対応してくれます。

世の中には、最初から、あるレベルでVBAとかできる人もいるようです。よく、Excel VBAを学ぶなら、Excel自体に詳しくなれという人がいますが、プログラミングを覚えようとするなら、Excel表計算は邪魔です。VBAは、VB6系の流れを汲むれっきとしたプログラミング言語なのです。

ホリエモンこと堀江貴文さんなども、何かの自力でプログラミングをして、相当なものを作ってしまったと言うそうです。

いきなり作りたいというのなら、フローチャートを作ってみるのが一番だと思います。その中で、いろんなワザを覚えたり集めて、それを使ってみることです。プログラミングでは、ワザのレパートリーが多いほど強みのようです。ワザは、アルゴリズムに似ていますが、それよりもずっと小規模です。プログラミング用語では、スニッペット(小技)と呼ばれるものです。

囲碁や将棋と似ている世界ではないかと思います。
最初は、既定の方法や定石を頼りに、対戦していきます。決して、定石を外してとは考えないことです。オセロの強い人が、同レベルの強いオセロのゲームを作ってしまうことは良く知られています。

残念ながら、そのワザを覚えるための手段が、近年不足しているようです。掲示板でも、時々、面白いワザを出す人がいますが、そう多くはありません。こまめに人のワザを読むことは大事ですが、雑な書き方をしていると、逆に自分の質を低下させる原因になるかと思います。

なくて七癖、私は、概ね、以下のように、配列を使います。
入力シートさえ、もう少し工夫すれば、コードは格段に簡単になります。
以下は、ほとんど参考にはならないはずです。しょせん、人の書いたコードというものは、手本とでも考えない限りは、その場限りになってしまうものだと思います。できれば、なるべく早く自分のスタイルを決めることが、上達の近道かもしれません。

'//
Sub ExpadingData()
　Dim sh1 As Worksheet
　Dim sh2 As Worksheet
　Dim x() As Variant '配列
　Dim a As Variant, n As Variant
　Dim mDate As Date
　Dim j As Long, i As Long, k As Long, t As Long, m As Long
　Dim bdrRw() As Long '境目
　
　Set sh1 = Worksheets("入力シート")
　Set sh2 = Worksheets("転記シート")
　
　With sh1
　　For i = 2 To .Cells(Rows.Count, 1).End(xlUp).Row
　　　If .Cells(i, 2).Value Like "◯*" Then
　　　　ReDim Preserve x(j)
　　　　x(j) = .Range(.Cells(i, 1), .Cells(i, 6))　'配列の代入
　　　　j = j + 1
　　　End If
　　Next i
　End With
　With sh2
　　k = .Cells(Rows.Count, 1).End(xlUp).Row + 1　'罫線引きの位置を特定
　　If k > 2 Then ReDim Preserve bdrRw(m): bdrRw(m) = k: m = m + 1
　　For j = LBound(x) To UBound(x)
　　　a = Application.Index(x(j), 1, 0)
　　　i = a(5)
　　　mDate = DateValue(Replace(a(6) & ".1", ".", "/")) 'ロケール設定
　　　t = 1
　　　For Each n In Array(1, 3, 4)
　　　　.Cells(k, t).Resize(i).Value = x(j)(1, n)
　　　　t = t + 1
　　　Next n
　　　'年月の代入
　　　.Cells(k, 4).Resize(i).NumberFormatLocal = "GE.M"
　　　.Cells(k, 4).Value = mDate
　　　.Cells(k, 4).AutoFill .Cells(k, 4).Resize(i), Type:=xlFillMonths
　　　k = k + i
　　　ReDim Preserve bdrRw(m): bdrRw(m) = k: m = m + 1
　　Next j
　　'罫線引き
　　For j = LBound(bdrRw) To UBound(bdrRw) - 1
　　　.Cells(bdrRw(j), 1).Resize(, 4).Borders(8).LineStyle = xlDouble
　　Next j
　End With
End Sub

'なお、sh1, sh2 のオブジェクトの解放が必要になるときがあります。