VBA 検索するSheetの位置の変更

質問

現在、グループの数だけユーザー名の合計数をSheet2に抽出するという
事をやっているのですが.......
コードの方は下記になります

Sub Sample3()
Dim i As Long, j As Long, k As Long, lastRow As Long, lastCol As Long
Dim wS2 As Worksheet, wS3 As Worksheet
Set wS2 = Worksheets("Sheet1")
Set wS3 = Worksheets("Sheet2")
Application.ScreenUpdating = False
If wS2.Range("Y1") = "" Then
wS2.Range("Y1") = "ダミー"
End If
With Worksheets("Sheet1")
If .Range("A4") = "" Then
.Range("A4") = "ダミー"
End If
lastRow = .Cells(Rows.Count, "B").End(xlUp).Row
Range(.Cells(5, "B"), .Cells(lastRow, "B")).AdvancedFilter Action:=xlFilterCopy, copytorange:=wS3.Range("A1"), unique:=True '★
For i = 2 To wS3.Cells(Rows.Count, "A").End(xlUp).Row
wS2.Cells(7, (i - 2) * 8 + 3) = wS3.Cells(i, "A")
.Range("A4").AutoFilter field:=2, Criteria1:=wS3.Cells(i, "A")
Range(.Cells(5, "AA"), .Cells(lastRow, "AA")).SpecialCells(xlCellTypeVisible).Copy wS2.Cells(7, (i - 2) * 8 + 2)
For k = wS2.Cells(Rows.Count, (i - 2) * 8 + 2).End(xlUp).Row To 7 Step -1
wS2.Cells(k, (i - 2) * 8 + 3) = WorksheetFunction.CountIfs(.Range("AA:AA"), wS2.Cells(k, (i - 2) * 8 + 2), .Range("B:B"), _
wS2.Cells(7, (i - 2) * 8 + 3))
If WorksheetFunction.CountIf(wS2.Columns((i - 2) * 8 + 2), wS2.Cells(k, (i - 2) * 8 + 2)) > 1 Then
wS2.Cells(k, (i - 2) * 8 + 2).Resize(, 2).Delete shift:=xlUp
End If
Next k
Next i
wS2.Range("B1").CurrentRegion.Borders.LineStyle = xlContinuous
wS2.Cells.Replace what:="ダミー", replacement:="", lookat:=xlWhole
.Cells.Replace what:="ダミー", replacement:="", lookat:=xlWhole
wS3.Cells.Clear
.AutoFilterMode = False
End With
Application.ScreenUpdating = True
End Sub

このコードで検索をかけるSheet1のセルBの文字をセルCに移動して検索かけたいという事なのですが、下記の用なコードでBをCに変更してみた結果エラーが発生してしまいます。

lastRow = .Cells(Rows.Count, "C").End(xlUp).Row
Range(.Cells(5, "C"), .Cells(lastRow, "C")).AdvancedFilter Action:=xlFilterCopy, copytorange:=wS3.Range("A1"), unique:=True '★
For i = 2 To wS3.Cells(Rows.Count, "A").End(xlUp).Row
wS2.Cells(7, (i - 2) * 8 + 3) = wS3.Cells(i, "A")
.Range("A4").AutoFilter field:=2, Criteria1:=wS3.Cells(i, "A")
Range(.Cells(5, "AA"), .Cells(lastRow, "AA")).SpecialCells(xlCellTypeVisible).Copy wS2.Cells(7, (i - 2) * 8 + 2)
For k = wS2.Cells(Rows.Count, (i - 2) * 8 + 2).End(xlUp).Row To 7 Step -1
wS2.Cells(k, (i - 2) * 8 + 3) = WorksheetFunction.CountIfs(.Range("AA:AA"), wS2.Cells(k, (i - 2) * 8 + 2), .Range("C:C"), _

どなたかご教授の方お願い致します。

回答No.3

tom04 · ベストアンサー

こんばんは！
細かい配置まで検証する気力がありませんが・・・

＞Grp1~10をB7に、yamada10xをC7に抽出するように変更
＞Grp1~10をJ7に、yamada4xをK7に抽出するように変更
と
＞Sheet1のyamada10xとyamada4xのセルBの位置をセルCに移動させたい場合なのですが
の件に関しては、↓の画像のような配置と解釈しています。

尚、
＞空けておいた３行に罫線が設定してしまい、繰り上がってきます。
＞これは wS2.Cells(k, (i - 2) * 8 + 2).Resize(, 2).Delete shift:=xlUp
＞重複しているセルの削除が関係しているのですか？？？

はい！その通りです。
文章だけでは、お手元にある表の細かいレイアウトは全く判りませんので
（もちろん質問にもそんなコトは書いてないので）そこまでの対処はしていません。

とりあえず今判っている問題点だけを考慮しもう一度コードにしてみました。
（削除したセルは追加して下側のセルのレイアウトに影響を与えないようにしています）

Sub Sample4()
Dim i As Long, j As Long, k As Long, lastRow As Long, lastCol As Long
Dim wS2 As Worksheet, wS3 As Worksheet
Set wS2 = Worksheets("Sheet2")
Set wS3 = Worksheets("Sheet3")
Application.ScreenUpdating = False
If wS2.Range("A1") = "" Then
wS2.Range("A1") = "ダミー"
End If
lastRow = wS2.UsedRange.Rows.Count
'▼7行目が項目行？なので7行目で最終列取得
lastCol = wS2.Cells(7, Columns.Count).End(xlToLeft).Column
If lastRow > 6 Then
For j = 2 To lastCol Step 8
Range(wS2.Cells(7, j), wS2.Cells(lastRow, j + 1)).ClearContents
Next j
End If '★←追加
With Worksheets("Sheet1")
'▼Sheet1の項目行は5行目？
If .Range("A5") = "" Then
.Range("A5") = "ダミー"
End If
'▼C列で最終行取得
lastRow = .Cells(Rows.Count, "C").End(xlUp).Row
'▼C列でフィルタ（重複なしでSheet3のA1セルに貼り付け）
Range(.Cells(5, "C"), .Cells(lastRow, "C")).AdvancedFilter Action:=xlFilterCopy, copytorange:=wS3.Range("A1"), unique:=True
'▼Sheet3の2行目～最終行まで
For i = 2 To wS3.Cells(Rows.Count, "A").End(xlUp).Row
'▼Sheet2の7行目に項目表示
wS2.Cells(7, (i - 2) * 8 + 2) = .Range("AA5")
'▼「○○の合計数」という表示形式ではなく、データそのまま
wS2.Cells(7, (i - 2) * 8 + 3) = wS3.Cells(i, "A")
'▼Sheet1の5行目のC列でオートフィルタ（Sheet3のi行A列でフィルタを掛ける）
.Rows(5).AutoFilter field:=3, Criteria1:=wS3.Cells(i, "A")
'▼AA列の表示されているデータをSheet2の8行目、(i-2)*8+2　列に貼り付け
Range(.Cells(6, "AA"), .Cells(lastRow, "AA")).SpecialCells(xlCellTypeVisible).Copy wS2.Cells(8, (i - 2) * 8 + 2)
wS3.Range("C:C").Clear
For k = wS2.Cells(Rows.Count, (i - 2) * 8 + 2).End(xlUp).Row To 8 Step -1
wS2.Cells(k, (i - 2) * 8 + 3) = WorksheetFunction.CountIfs(.Range("AA:AA"), wS2.Cells(k, (i - 2) * 8 + 2), .Range("C:C"), _
wS2.Cells(7, (i - 2) * 8 + 3))
If WorksheetFunction.CountIf(wS2.Columns((i - 2) * 8 + 2), wS2.Cells(k, (i - 2) * 8 + 2)) > 1 Or _
wS2.Cells(k, (i - 2) * 8 + 3) = 0 Then
wS2.Cells(k, (i - 2) * 8 + 2).Resize(, 2).Delete shift:=xlUp
'▼削除したセルの1行下を挿入
wS2.Cells(k + 1, (i - 2) * 8 + 2).Resize(, 2).Insert shift:=xlDown
End If
Next k
Next i
wS2.Columns.AutoFit
wS2.Cells.Replace what:="ダミー", replacement:="", lookat:=xlWhole
.Cells.Replace what:="ダミー", replacement:="", lookat:=xlWhole
wS3.Cells.Clear
.AutoFilterMode = False
End With
'▼Sheet2のB7セルと連続しているセルに格子の罫線
wS2.Range("B7").CurrentRegion.Borders.LineStyle = xlContinuous
Application.ScreenUpdating = True
End Sub

※　今までのコードで行・列合わせは理解の方法は理解できたと思いますので、
後はご自身で頑張ってみてください。m(_ _)m

回答No.2

tom04

こんばんは！

前回回答した者です。
大幅にレイアウトが変わっているようなので詳しく検証はしていませんが、
お示しのコードで
＞Set wS2 = Worksheets("Sheet1")
＞Set wS3 = Worksheets("Sheet2")
は
＞Set wS2 = Worksheets("Sheet2")
＞Set wS3 = Worksheets("Sheet3")
としなければちゃんと動かないと思います。

もう一度コードを載せてみます。
前回のコードそのままですが、コメントを加えています。
↓の画像と照らし合わせて列・行合わせの参考にしてみてください。
画像ではSheet3が表示されていますが、↓のコードではSheet3のデータを削除していますので、
確認できません。
実際のSheet3は↓の画像のようになります。

Sub Sample3()
Dim i As Long, j As Long, k As Long, lastRow As Long, lastCol As Long
Dim wS2 As Worksheet, wS3 As Worksheet
Set wS2 = Worksheets("Sheet2")
Set wS3 = Worksheets("Sheet3") '←★（作業用Sheet=Sheet3）
Application.ScreenUpdating = False '★画面更新停止
If wS2.Range("A1") = "" Then
wS2.Range("A1") = "ダミー" '★Sheet2のA1が空白の時（Usedrangeで最終行取得するためのダミー"
End If
lastRow = wS2.UsedRange.Rows.Count '★Sheet2の最終行取得
lastCol = wS2.Cells(10, Columns.Count).End(xlToLeft).Column 'Sheet2の10行目最終列取得
If lastRow > 9 Then '★最終行が10行以上ある場合
For j = 4 To lastCol Step 5 '★D列～最終列まで5列おき（画像ではD・I・N・・・列が「Grp番号」となっているため）
Range(wS2.Cells(10, j), wS2.Cells(lastRow, j + 1)).ClearContents '★Sheet2の10行目j列～最終行j列の右隣りの列データ消去
Next j
End If
With Worksheets("Sheet1") '★Sheet1の・・・
If .Range("A4") = "" Then '★A4セルが空白の場合
.Range("A4") = "ダミー" '★A4セルにデータを入れる（オートフィルタの項目用として）
End If
lastRow = .Cells(Rows.Count, "B").End(xlUp).Row '★lastRowはSheet1のB列最終行
'★Sheet1のB4～B列最終行データを重複なしに作業用Sheet3のA1セル以降にコピー＆ペースト
Range(.Cells(4, "B"), .Cells(lastRow, "B")).AdvancedFilter Action:=xlFilterCopy, copytorange:=wS3.Range("A1"), unique:=True
For i = 2 To wS3.Cells(Rows.Count, "A").End(xlUp).Row '★i はSheet3のA2～最終行まで
wS2.Cells(10, (i - 2) * 5 + 4) = .Range("F4") '★iは2から始まるので、Sheet2の10行目(i-2)*5+4 ← （i=2　の場合はD列となる）はSheet1のF4セルを
wS2.Cells(10, (i - 2) * 5 + 5) = wS3.Cells(i, "A") '★上の行の右隣りのセルはSheet3のA列i行目のデータを（Grp1とかGrp2という値）
wS2.Cells(10, (i - 2) * 5 + 5).NumberFormatLocal = "@の合計数" '★そのセルの表示形式を「Grp1の合計数」のように表示させる
.Range("A4").AutoFilter field:=2, Criteria1:=wS3.Cells(i, "A") 'Sheet1のB4セル以降、Sheet3のA列i行目データでフィルタを掛ける
'★Sheet1のF5～F列最終行で表示されているデータをSheet2の11行目、(i-2)*5+4　列に貼り付け(iが2の時はD列となる）
Range(.Cells(5, "F"), .Cells(lastRow, "F")).SpecialCells(xlCellTypeVisible).Copy wS2.Cells(11, (i - 2) * 5 + 4)

'★kはSheet2の (i-2)*5+4 列の最終行から11行目まで上に向かって (←i=2　の時はD列となる、3の時はI列・・・)
For k = wS2.Cells(Rows.Count, (i - 2) * 5 + 4).End(xlUp).Row To 11 Step -1
'★Sheet2の k行目、(i-2)*5+5 列（i=2の時はE列）でSUMUIF関数摘要
'★SUMIF関数の「範囲」はSheet1のF列、「検索条件」はSheet2の関数を入力する左となりのセル、「合計範囲」はSheet1のB列
wS2.Cells(k, (i - 2) * 5 + 5) = WorksheetFunction.CountIfs(.Range("F:F"), wS2.Cells(k, (i - 2) * 5 + 4), .Range("B:B"), _
wS2.Cells(10, (i - 2) * 5 + 5))
'★Sheet2の　k行目、(i-2)*5+4 列（←i=2の時はD列）が複数存在する場合
If WorksheetFunction.CountIf(wS2.Columns((i - 2) * 5 + 4), wS2.Cells(k, (i - 2) * 5 + 4)) > 1 Then
'★Sheet2の k行、(i-2)*5+4 列と右隣りのセルを削除（←これが少し無駄かもしれません、あらかじめ重複なしに表示しておけば不要）
wS2.Cells(k, (i - 2) * 5 + 4).Resize(, 2).Delete shift:=xlUp
End If
Next k
Next i
wS2.Columns.AutoFit '★Sheet2の列幅調整
wS2.Cells.Replace what:="ダミー", replacement:="", lookat:=xlWhole '★Sheet2の「ダミー」というセルがあればそのセルを消去
.Cells.Replace what:="ダミー", replacement:="", lookat:=xlWhole 'Sheet1の「ダミー」というセルがあればそのセルを消去
wS3.Cells.Clear '★Sheet3（作業用Sheet）のデータをすべて削除
.AutoFilterMode = False '★Sheet1のオートフィルタモードを解除
End With
Application.ScreenUpdating = True
End Sub

とりあえずこの程度で・・・m(_ _)m

補足

またのご回答とご説明ありがとうございます。
質問に関しまして、私の説明不足・記載ミス・入力ミスでした。
色々とコードを変えてみまして、
Sub Sample3()
Dim i As Long, j As Long, k As Long, lastRow As Long, lastCol As Long
Dim wS2 As Worksheet, wS3 As Worksheet
Set wS2 = Worksheets("Sheet2")
Set wS3 = Worksheets("Sheet3")
Application.ScreenUpdating = False
If wS2.Range("A1") = "" Then
wS2.Range("A1") = "ダミー"
End If
lastRow = wS2.UsedRange.Rows.Count
lastCol = wS2.Cells(7, Columns.Count).End(xlToLeft).Column
If lastRow > 6 Then
For j = 2 To lastCol Step 8 ）
Range(wS2.Cells(7, j), wS2.Cells(lastRow, j + 1)).ClearContents
Next j
With Worksheets("Sheet1")
If .Range("A4") = "" Then
.Range("A4") = "ダミー"
End If
lastRow = .Cells(Rows.Count, "B").End(xlUp).Row
Range(.Cells(5, "B"), .Cells(lastRow, "B")).AdvancedFilter Action:=xlFilterCopy, copytorange:=wS3.Range("A1"), unique:=True '★
For i = 2 To wS3.Cells(Rows.Count, "A").End(xlUp).Row
wS2.Cells(7, (i - 2) * 8 + 2) = .Range("AA5")
wS2.Cells(7, (i - 2) * 8 + 3) = wS3.Cells(i, "A")
.Range("A4").AutoFilter field:=2, Criteria1:=wS3.Cells(i, "A")
Range(.Cells(5, "AA"), .Cells(lastRow, "AA")).SpecialCells(xlCellTypeVisible).Copy wS2.Cells(7, (i - 2) * 8 + 2)
For k = wS2.Cells(Rows.Count, (i - 2) * 8 + 2).End(xlUp).Row To 7 Step -1
wS2.Cells(k, (i - 2) * 8 + 3) = WorksheetFunction.CountIfs(.Range("AA:AA"), wS2.Cells(k, (i - 2) * 8 + 2), .Range("B:B"), _
wS2.Cells(7, (i - 2) * 8 + 3))
If WorksheetFunction.CountIf(wS2.Columns((i - 2) * 8 + 2), wS2.Cells(k, (i - 2) * 8 + 2)) > 1 Then
wS2.Cells(k, (i - 2) * 8 + 2).Resize(, 2).Delete shift:=xlUp
End If
Next k
Next i
wS2.Columns.AutoFit
wS2.Cells.Replace what:="ダミー", replacement:="", lookat:=xlWhole
.Cells.Replace what:="ダミー", replacement:="", lookat:=xlWhole
wS3.Cells.Clear
.AutoFilterMode = False
End With
Application.ScreenUpdating = True
End Sub

変更した内容としましては、
Sheet1
Grp1~10をAA列に変更、4行にあったUsernameとGrp番号を削除して、5行だけにyamada10x・yamada4x・Grp1~10を.....

Sheet2
Grp1~10をB7に、yamada10xをC7に抽出するように変更
Grp1~10をJ7に、yamada4xをK7に抽出するように変更
DEIJセル10にあった　Grp番号、@の合計数　を抽出させないにし、
Grp1~10とその合計数の値だけをSheet2に抽出させるように変更

といった感じのコードに変えていました。

今回質問させて頂いた内容としましては....
Sheet1のyamada10xとyamada4xのセルBの位置をセルCに移動させたい場合なのですが、
lastRow = .Cells(Rows.Count, "C").End(xlUp).Row
Range(.Cells(5, "C"), .Cells(lastRow, "C")).AdvancedFilter Action:=xlFilterCopy, copytorange:=wS3.Range("A1"), unique:=True '★
For i = 2 To wS3.Cells(Rows.Count, "A").End(xlUp).Row
wS2.Cells(7, (i - 2) * 8 + 2) = .Range("AA5")
　wS2.Cells(7, (i - 2) * 8 + 3) = wS3.Cells(i, "A")
.Range("A4").AutoFilter field:=2, Criteria1:=wS3.Cells(i, "A")
Range(.Cells(5, "AA"), .Cells(lastRow, "AA")).SpecialCells(xlCellTypeVisible).Copy wS2.Cells(7, (i - 2) * 8 + 2)
For k = wS2.Cells(Rows.Count, (i - 2) * 8 + 2).End(xlUp).Row To 7 Step -1
wS2.Cells(k, (i - 2) * 8 + 3) = WorksheetFunction.CountIfs(.Range("AA:AA"), wS2.Cells(k, (i - 2) * 8 + 2), .Range("C:C"), _

というセルBをセルCに変更させたのですが、オブジェクトエラーが出てしまい、
実行結果が得られないという事でした。

何度も質問してしまし申し訳ございません。
ご教授の方お願い致します。

後こちら補足なのですが、
Sheet2でセルA1~50からセルK1~50、3行空けまして、セルA54~104からセルK54~104
にあらかじめ罫線を設定をし、一番上のコードを実行してみた結果
抽出したセルの列が、行数100あたりから104あたりまで罫線が削除されてしまい、あらかじめ
空けておいた３行に罫線が設定してしまい、繰り上がってきます。
これは wS2.Cells(k, (i - 2) * 8 + 2).Resize(, 2).Delete shift:=xlUp
重複しているセルの削除が関係しているのですか？？？

回答No.1

eden3616

http://okwave.jp/qa/q8773631.html
http://okwave.jp/qa/q8778309.html
過去質問・回答見ましたがSheet2の様式が変わっているのかな？

処理内容にコメントでもあると見やすいかと。
継続質問のようですので、新参者が入るべきではないでしょうが中途半端に回答致します。
処理内容の検証は行っていないうえに、以下のコードはご提示のコードのままです（一部最適化していますが）。

「AA」列ってなんでしょうね。
「(i - 2) * 8 + 3)」で「i = 5」のとき「AA」列になりますので、これをキーとでもしているのでしょうか。

B列をC列に変更する目的はなんなんでしょうか。
様式変更を想定しタ場合、変更するうえで、影響しそうなのは

(1)直接B列を指定している箇所（コメント先頭番号：1, 2, 8）
　　B列をC列に変更する必要がある

(2)8列置きに等間隔で出力するセルを指定している箇所(4, 6, 7, 8, 9, 10)
　　「i = 2」のとき、「(i - 2) * 8 + 2)」、「(i - 2) * 8 + 3)」は
　　2、3列（B、C列）となるため、右側へ1列シフトする必要がある

(3)「AA」列を指定している箇所(6, 8)
　　(2)により１列ずらして「AB」とする必要がある

てとこでしょうか・・・。
検証しているわけではないので違っているかもしれませんがご参考までに。

■コード

Sub Sample3()
Dim i As Long, j As Long, k As Long, lastRow As Long, lastCol As Long
Dim wS2 As Worksheet, wS3 As Worksheet
Set wS2 = Worksheets("Sheet1")
Set wS3 = Worksheets("Sheet2")

Application.ScreenUpdating = False
With wS2
　　If .Range("Y1") = "" Then .Range("Y1") = "ダミー"
　　If .Range("A4") = "" Then .Range("A4") = "ダミー"
'1 ▼Sheet1のB列の最終行を取得
　　lastRow = .Cells(Rows.Count, "B").End(xlUp).Row
'2 ▼Sheet1のB5：B最終行にオートフィルタ設定
　　.Range(.Cells(5, "B"), .Cells(lastRow, "B")).AdvancedFilter _
　　 Action:=xlFilterCopy, copytorange:=wS3.Range("A1"), unique:=True
'3 ▼Sheet2の2行目からA列最終行分の繰り返し処理
　　For i = 2 To wS3.Cells(Rows.Count, "A").End(xlUp).Row
'4　　 ▼Sheet1の7行、3,11,19…（C,K,S…）列にSheet2のA列を書出し
　　　　.Cells(7, (i - 2) * 8 + 3) = wS3.Cells(i, "A")
'5　　 ▼Sheet1のA4セルにSheet2のA列の各行でフィルタを設定
　　　　.Range("A4").AutoFilter field:=2, Criteria1:=wS3.Cells(i, "A")
'6　　 ▼Sheet1のAA列5～B列の最終行までのフィルタ結果を
'　　　　 7行、2,10,18…（B,J,R…）列にコピー
　　　　.Range(.Cells(5, "AA"), .Cells(lastRow, "AA")).SpecialCells( _
　　　　 xlCellTypeVisible).Copy .Cells(7, (i - 2) * 8 + 2)
'7　　 ▼Sheet1でコピーした結果の最終行から7行目までを繰り返し処理
　　　　For k = .Cells(Rows.Count, (i - 2) * 8 + 2).End(xlUp).Row To 7 Step -1
'8　　　　 ▼Sheet1の同じ行の右隣の列にCountIfsで複数条件一致した数を書出し
'　　　　　　　条件1：Sheet1のAA列が2,10,18…（B,J,R…）列と同じ
'　　　　　　　条件2：Sheet2のB列が3,11,19…（C,K,S…）列と同じ
　　　　　　.Cells(k, (i - 2) * 8 + 3) = WorksheetFunction.CountIfs( _
　　　　　　 .Range("AA:AA"), .Cells(k, (i - 2) * 8 + 2), _
　　　　　　 .Range("B:B"), .Cells(7, (i - 2) * 8 + 3))
'9　　　　 ▼2,10,18…（B,J,R…）列の値で重複値が2つ以上であれば処理
　　　　　　If WorksheetFunction.CountIf(.Columns((i - 2) * 8 + 2), _
　　　　　　 .Cells(k, (i - 2) * 8 + 2)) > 1 Then
'10　　　　　　 ▼その行の2,10,18…（B,J,R…）列と右隣の列を削除して上詰め
　　　　　　　　.Cells(k, (i - 2) * 8 + 2).Resize(, 2).Delete shift:=xlUp
　　　　　　End If
　　　　Next k
　　Next i
　　.Range("B1").CurrentRegion.Borders.LineStyle = xlContinuous
　　.Cells.Replace what:="ダミー", replacement:="", lookat:=xlWhole
　　.Cells.Replace what:="ダミー", replacement:="", lookat:=xlWhole
　　wS3.Cells.Clear
　　.AutoFilterMode = False
End With
Application.ScreenUpdating = True
End Sub