[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『マクロでループ処理の記載方法について。お願いします。』（スマトラ）
お世話になっております。
ループ処理の仕方がわからず困っております。
下記の２つ「抽出作業」と「データ転記」各々単体で目的にかなった動きをしております。
これを、一つにまとめて完結させたいと考えております。
実際に２つのマクロを一つにまとめて記載したところ
「転記元データ抽出」→「転記」ループ→「転記元データ抽出」→「転記」・・・・といくはずでしたが
「データ元データ抽出」→「転記」ループ→「転記」・・・・・と転記だけループされてしまいます。
どうも、 Next i、 Next iiの設置位置がまずいのかなと思いつつ、質問させていただきました。
皆さま、どうかアドバイスの程、なにとぞよろしくお願い致します。
（抽出作業マクロの処理概要）
※下記の処理はフィルタでデータを表示させ「データ転記マクロ」で転記させることを想定したテスト用です。
・シートの1行目74列目〜80列目を左から順次調べて最初に値があったセルを処理範囲の起点「co」とします
・2行目にオートフィルタが設置してあり、起点列をフィルタ操作にて値を表示させます。
・Nextで次の列に移り最終的に起点列から7列目で処理を終了
Sub 抽出作業()
Dim sh1, sh2 As Worksheet: Set sh1 = Worksheets("管_予")
Dim r As Long, co As Long 'i:カウンタ co:基点セル
co = 74 '基準セル
For r = 1 To 6 '開始列(1+6)=7列目まで処理
If sh1.Cells(1, co + r) <> "" Then '1行目に値有:処理。無:飛ばす
With sh1.Range("A2") '日計抽出
.Sort key1:=.Cells(2, co + r), order1:=xlAscending, Header:=xlYes '日付昇順
.CurrentRegion.AutoFilter Field:=co + r, Criteria1:="<>" '日付値のみ）
.Sort key1:=.Range("E2"), order1:=xlAscending, Header:=xlYes '固定昇順
End With
If sh1.FilterMode = True Then sh1.ShowAllData 'フィルタ解除
End If '1行目に値ない場合の飛び位置
r = r
Next r '利用日
r = 0
End Sub
（データ転記マクロの処理概要）
※上記マクロで表示されたセル範囲を別シートに転記するマクロで、転記範囲は37列毎に横へズレながら転記します。
・オートフィルタで絞り込みがされているか確認しフィルタ絞り込有無で処理か中止する。
・基本項目の所定範囲の可視セルを別シートへ値貼り付け→続けて、基本項目の詳細部分を更に抽出し転記
・初回転記は「B3:Ak」」→次「AN3:BW」→次・・・・37列毎に転記・・・7エリア転記で終了
Sub データ転記()
Dim sh1, sh2 As Worksheet, d As Long
Set sh1 = Worksheets("管_予")'転記元
Set sh2 = Worksheets("TP")'転記先
Dim i, 予, 日, 入 As Long'i→カウンタ、他は転記先の行数
予 = 3: 日 = 3: 入 = 61
If sh1.AutoFilter.FilterMode Then 'オートフィルタが絞りこまれているかどうかの確認
'★基本項目の転記
For i = 1 To 265 Step 37 '開始列（2列目）〜最終列（265列目）を37列おきに転記 '列のi設定→36+i
With sh1 '転記先←転記元（フィルタ有:可視セル転記）
d = .Cells(.Rows.Count, "B").End(xlUp).Row
.Range(.Cells(予, 36), .Cells(d, 36)).Copy: sh2.Cells(日, 2 + i).PasteSpecial (xlPasteValues) '日計:担当
'（割愛:上記の転記処理が10項目程度あり）
End With
i = i + 1
Next i
i = 0 '終了後カウンタをクリア
'★基本項目-詳細部分の抽出と転記
Dim ii As Long
For ii = 1 To 265 Step 37 '更に絞り込むため別処理扱い）
With sh1
.Range("A2").Sort key1:=.Range("AR2"), order1:=xlAscending, Header:=xlYes '優先順
.Range("A2").CurrentRegion.AutoFilter Field:=44, Criteria1:="<=2" '2以下
.Range(.Cells(予, 12), .Cells(d, 12)).Copy: sh2.Cells(入, 1 + ii).PasteSpecial (xlPasteValues) '名前
.Range(.Cells(予, 44), .Cells(d, 44)).Copy: sh2.Cells(入, 2 + ii).PasteSpecial (xlPasteValues) '優先順
End With
ii = ii + 1
Next ii
ii = 0
Else
sh1.Select: MsgBox "転記データ未選択"
End If
End Sub
＜ 使用 Excel：Excel2010、使用 OS：Windows7 ＞
は、何をしているのでしょうか？
（マナ） 2018/05/10(木) 21:36
データ抽出とは
＞.Range("A2").CurrentRegion.AutoFilter Field:=44, Criteria1:="<=2" '2以下
これのことでしょうか？
何回ループしても、同じものが抽出されているだけでは？
（マナ） 2018/05/10(木) 21:49
処理についてですが。
以下の処理の流れでデータを転記させています。
'★基本項目の転記
＞i = i + 1
For i = 1 To 265 の「Step 37」で転記先を右列へずらしながら転記先を指定しています。
'★基本項目-詳細部分の抽出と転記
＞ii = ii + 1
For ii = 1 To 265 Step 37
この部分は
.Range("A2").Sort key1:=.Range("AR2"), order1:=xlAscending, Header:=xlYe・・・・
とSortするコードがありますが、基本項目を転記後、更にSortして得た値を同様にコピ、貼り付けしています。
何回ループしても、同じものが抽出されているだけでは？
そうなんです、何回やっても同じものが転記されます。
各コード単体では、きちんと動作するのですがこれを、合体させてループ処理コードを書くのができなくて困っています。
処理の流れは、ざっくりですが・・・
(1)転記元シートをSortし「○データ」を表示させる
↓
(2)転記元セル=「A1」と「○列値」をコピー
↓
(3)転記先セル=「A1」と「AA1」へ貼り付け
↓
★次の処理（ループ1）
↓
(2-1)転記元シートをSortし「△データ」を表示させる
↓
(2-2)転記元セル=「A1」と「△列値」をコピー
↓
(2-3)転記先セル=「A1」と「AB1」へ貼り付け
↓
★次の処理（ループ2）
↓
(3-1)転記元シートをSortし「□データ」を表示させる
↓
(3-2)転記元セル=「A1」と「□列値」をコピー
↓
(3-3)転記先セル=「A1」と「AC1」へ貼り付け
↓
★次の処理（ループ3）
↓
繰り返し
・転記元シートSort表示値「○→△→□→●→▲→■→◇」と計7回処理
・転記元セル範囲は「固定範囲」と「流動的なSort列」を取得し
・転記先セルをずらしながら
「A→B→C→D→E→F→G」&「AA→AB→AC→AD→AE→AF→AG」と計7回処理
単純に下記のように合体させたのですが、i,ii,NEXTなどの位置が悪くエラーだらけです。
Sub 抽出と転記()
Dim sh1, sh2 As Worksheet, d As Long
Set sh1 = Worksheets("管_予") '転記元
Set sh2 = Worksheets("TP") '転記先
Dim r As Long, co As Long 'i:カウンタ co:基点セル
Dim i, 予, 日, 入 As Long 'i→カウンタ、他は転記先の行数
予 = 3: 日 = 3: 入 = 61
Dim ii As Long
If sh1.FilterMode = True Then sh1.ShowAllData 'フィルタ解除
co = 74 '基準セル
'★データ抽出
For r = 1 To 6 '開始列(1+6)=7列目まで処理
If sh1.Cells(1, co + r) <> "" Then '1行目に値有:処理。無:飛ばす
With sh1.Range("A2") '日計抽出
.Sort key1:=.Cells(2, co + r), order1:=xlAscending, Header:=xlYes '日付昇順
.CurrentRegion.AutoFilter Field:=co + r, Criteria1:="<>" '日付値のみ）
.Sort key1:=.Range("E2"), order1:=xlAscending, Header:=xlYes '固定昇順
End With
'★基本項目転記
For i = 1 To 265 Step 37 '開始列（2列目）〜最終列（265列目）を37列おきに転記 '列のi設定→36+i
With sh1 '転記先←転記元（フィルタ有:可視セル転記）
d = .Cells(.Rows.Count, "B").End(xlUp).Row
.Range(.Cells(予, 36), .Cells(d, 36)).Copy: sh2.Cells(日, 2 + i).PasteSpecial (xlPasteValues) '日計:担当
'（割愛:上記の転記処理が10項目程度あり）
End With
'★基本項目-詳細部分の抽出転記
For ii = 1 To 265 Step 37 '更に絞り込むため別処理扱い）
With sh1
.Range("A2").Sort key1:=.Range("AR2"), order1:=xlAscending, Header:=xlYes '優先順
.Range("A2").CurrentRegion.AutoFilter Field:=44, Criteria1:="<=2" '2以下
.Range(.Cells(予, 12), .Cells(d, 12)).Copy: sh2.Cells(入, 1 + ii).PasteSpecial (xlPasteValues) '名前
.Range(.Cells(予, 44), .Cells(d, 44)).Copy: sh2.Cells(入, 2 + ii).PasteSpecial (xlPasteValues) '優先順
End With
i = i + 1 '★基本項目転記
Next i '★基本項目転記
i = 0 '★基本項目転記
ii = ii + 1 '★基本項目-詳細部分の抽出転記
Next ii '★基本項目-詳細部分の抽出転記
ii = 0 '★基本項目-詳細部分の抽出転記
End If '1行目に値ない場合の飛び位置
r = r '★データ抽出
Next r '★データ抽出
r = 0 '★データ抽出
End Sub
（スマトラ） 2018/05/10(木) 23:40
Dim rngTable As Range
Dim rngKey As Range
Dim rngkey2 As Range
Dim rngCopyTo As Range
Dim c As Range
Dim i As Long
With Worksheets("管_予")
Set rngTable = .UsedRange.Offset(1)
Set rngKey = .Range("BV3:CB3")
Set rngkey2 = .Range("AR3")
End With
With Worksheets("TP")
Set rngCopyTo = .Range("A:AK,AL:BV,BW:DG,DH:ER,ES:GC,GD:HN,HO:IY")
End With
For Each c In rngKey
i = i + 1
If c.Value <> Empty Then
With rngTable
If .Worksheet.AutoFilterMode Then .AutoFilter
.Sort key1:=c, Header:=xlYes
.Sort key1:=rngkey2, Header:=xlYes
.AutoFilter Field:=c, Criteria1:="<>"
.AutoFilter Field:=rngKey.Column, Criteria1:="<=2"
With .Offset(1)
.Columns(36).Copy: rngCopyTo.Areas(i).Cells(1).PasteSpecial (xlPasteValues) '日計:担当
.Columns(12).Copy: rngCopyTo.Areas(i).Cells(2).PasteSpecial (xlPasteValues) '名前
.Columns(44).Copy: rngCopyTo.Areas(i).Cells(3).PasteSpecial (xlPasteValues) '優先順
End With
.AutoFilter
End With
End If
Next
End Sub
説明では1個のループ処理しかしてないのに、
コードだとiとiiの2回ループ処理が出てきますよね？
1連の処理なんだから、
1連で処理する手順を考えましょう。
＞「A→B→C→D→E→F→G」&「AA→AB→AC→AD→AE→AF→AG」と計7回処理
う〜ん。基準のセルを決めてそこからの「相対位置」で、
セルの位置を表現できるといいですね。
Range("C5").Cells(3,4").Select
↑これはどのセルが選択されるとおもいます？
こういう、実験コードを試してみて、VBA流のセルの位置の表現を覚えていってみては、
いかがでしょうか。
（まっつわん） 2018/05/11(金) 00:49
アドバイスありがとうございます。
1連の処理でできる工夫ですね。
がんばってみます。
（スマトラ） 2018/05/11(金) 08:59
中間報告です。
転記方法などの仕様までふくめて作り直し、バッチリ動きました。
もう少し、いじってみたいと思います。
〜略〜
For i = 1 To 6 '開始列(1+6)=7列目まで処理
If sh1.Cells(1, c + i) <> "" Then '1行目に値有:処理。無:飛ばす
If sh1.FilterMode = True Then sh1.ShowAllData 'フィルタ解除し次の列データ抽出準備
'抽出処理
With sh1.Range("A2") '日計抽出
.Sort key1:=.Cells(2, c + i), order1:=xlAscending, Header:=xlYes '日付昇順
.CurrentRegion.AutoFilter Field:=c + i, Criteria1:="<>" '日付値のみ）
.Sort key1:=.Range("E2"), order1:=xlAscending, Header:=xlYes '固定昇順
End With
'転記処理
With sh1 '転記先←転記元
d = .Cells(Rows.Count, 1).End(xlUp).Row 'フィルタ可視セル行カウント数を最終行と指定する
'流動転記範囲
sh2.Range(sh2.Cells(r, 17), sh2.Cells(d - 3 + r, 17)).Value = .Range(.Cells(3, c + i), .Cells(d, c + i)).Value '予定
〜中略〜
End With
r = r + 52'52行おきに転記先を指定
i = i
End If
Next i
End Sub
（スマトラ） 2018/05/12(土) 15:10
これは、何をしていますか。
＞i = i + 1
これについても、説明いただきましたが、わかりませんでした。
使用方法を誤解しているような気がします。
'----
＞.CurrentRegion.AutoFilter
.CurrentRegionは、２行上で記述するとよいのでは。
（マナ） 2018/05/12(土) 15:43
遅くなりました。
i→転記元の列範囲を特定（転記元シートの1行目74列目〜日付（7日×6週=42列）
月日数を日曜日始まりで、カレンダー通りに転記すると、列の前後に空白ができますので、空白を飛ばす処理をしています。
なので、iで日曜〜土曜の列単位に行のDataを抽出して転記します。
ii→要らなかったようです。iの処理後に更にフィルタで絞り込する際に使用していました。
（スマトラ） 2018/05/14(月) 13:35
＞i = i + 1 や ＞i = i の記述がありますが こんな使い方どこで学びましたか？
For i = 1 To 265 Step 37
（略)
i = i + 1
Next i
For i = 1 To 6
（略)
i = i
Next i
（マナ） 2018/05/14(月) 19:03
おはようございます。
ネットでやりたい処理に近いことをいろいろと調べているうちにです。
結局、処理の流れがごちゃごちゃになってきましたが(^_^;)
（スマトラ） 2018/05/15(火) 09:07
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.