ここから本文です

エクセルにのマクロについて

emx********さん

2019/1/311:59:11

エクセルにのマクロについて

お世話になっております。
ご教示願います。

下記のコードは
Sub Sample()
Dim j As Long, c As Range, r As Long
Dim FoundCell As Range, FirstCell As Range
Sheets("集計シート").Activate
With Sheets(" 何々商店 シート ")
j = .Cells(Rows.Count, "CR").End(xlUp).Row
For Each c In .Range("CR2:CR" & j)
Set FoundCell = .Range("CQ:CQ").Find(What:=c.Text, LookIn:=xlValues)
Set FirstCell = FoundCell
Do
If Not FoundCell Is Nothing Then
.Cells(FoundCell.Row, 5).Resize(, 6).Copy Cells(r + 6, 3)
r = r + 1
End If
Set FoundCell = .Range("CQ:CQ").FindNext(FoundCell)
If FoundCell.Address = FirstCell.Address Then
Exit Do
End If
Loop
Next c
End With
End Sub

CR列の2行目より下に、検索条件を入力しCQ列に○があったら【集計】Sheetへコピペしリスト化するコードになっているのですが、こちらのコードを【 集計 】Sheetではなく【集計.xlsm】 Bookに抽出できるようにしたいと思っております。また、検索条件を使わず「直接CQ列の○を見に行きコピペが出来る」ような仕組みを作りたいのですが初心者で何も分かりません。※CQには22行目から1000行まであり、COに入力されたら【=IF(CO22="","","○")】関数で○になるようにしています。

恐縮なのですが教えていただければ幸いです。
よろしくお願い致します。

追記
また、商店ごとに各一つ【何々商店Book1】を持ってるのでBookが30Bookあります。(同じフォーマットデータ)それを【何々商店Book1】の○が付いてる行のみ【集計.xlsm 】Bookへ集約して蓄積されたら嬉しいんです。

補足○が消える事もございます。
一度リスト化したものが更新され
【集計.xlsm 】が上書き出来ればより効率化になります。
よろしくお願いします。

閲覧数:
140
回答数:
2

違反報告

ベストアンサーに選ばれた回答

プロフィール画像

カテゴリマスター

kky********さん

2019/1/315:18:29

マクロは、集計.xlsm に入れて下さい。

複数のブックは一つのフォルダに入っているとします。
そのフォルダを先頭の
fpath As String = "C:\Data\"
の部分で設定して下さい。

>Sheets(" 何々商店 シート ")
何々のところはブックごとに変わるのでコードで固定で書けませんので、複数のブックの一番目のシートを処理対象とします。
ファイル名と同じシート名のような規則があれば書けますが。

Sub Sample()
fpath As String = "C:\Data\"
Dim fname As String
Dim wb As Workbook
Dim sh1 As Worksheet, sh2 As Worksheet
Dim i As Long, j As Long
Application.ScreenUpdating = False
Set sh1 = ThisWorkbook.Worksheets("集計シート")
With sh1
If .Range("C6").Value <> "" Then
.Range("C6:H" & .Cells(Rows.Count, "C").End(xlUp).Row).ClearContents
End If
End With
j = 5
fname = Dir(fpath & "*.xlsx", vbNormal)
Do Until fname = ""
Set wb = Workbooks.Open(fpath & fname)
Set sh2 = wb.Worksheets(1) '" 何々商店 シート "
With sh2
For i = 2 To .Cells(Rows.Count, "CQ").End(xlUp).Row
If .Range("CQ" & i).Value = "○" Then
j = j + 1
.Range("E" & i & ":J" & i).Copy Destination:=sh1.Range("C" & j)
End If
Next i
End With
wb.Close
fname = Dir()
Loop
Application.ScreenUpdating = True
End Sub

返信を取り消しますが
よろしいですか?

  • 取り消す
  • キャンセル

ベストアンサー以外の回答

1〜1件/1件中

vcx********さん

2019/1/314:25:13

希望にそっているか解りませんので、試す場合はテスト環境で。
データの更新までは考慮してないので、全部消してから再実行する運用です。

マクロは 集計.xlsm に置く前提です。
「集計.xlsm」と転記させたい「何々商店Book」を開いて、何々商店Bookの転記させたいシートをアクティブにしてから実行します。
「何々商店Book」のアクティブシートのセル CQ22:CQ1000 に「○」がある同行の E列からJ列 を「集計.xlsm」の「集計シート」のC列に順次転記します。


Sub Test()
Dim cws As Worksheet, pws As Worksheet, r As Range, LRow As Long

Set cws = ActiveSheet
If cws.Parent Is ThisWorkbook Then
   MsgBox "転記元ブックのシートをアクティブに" & vbCrLf & _
          "してから実行して下さい。", vbExclamation, "中止"
   Exit Sub
End If

Set pws = ThisWorkbook.Worksheets("集計シート")

For Each r In cws.Range("CQ2:CQ1000")
    If r.Value = "○" Then
       LRow = pws.Cells(pws.Rows.Count, "C").End(xlUp).Row + 1
       r.EntireRow.Cells(1, 5).Resize(1, 6).Copy pws.Cells(LRow, "C")
    End If
Next r

End Sub

返信を取り消しますが
よろしいですか?

  • 取り消す
  • キャンセル

みんなで作る知恵袋 悩みや疑問、なんでも気軽にきいちゃおう!

Q&Aをキーワードで検索:

Yahoo! JAPANは、回答に記載された内容の信ぴょう性、正確性を保証しておりません。
お客様自身の責任と判断で、ご利用ください。
本文はここまでです このページの先頭へ

「追加する」ボタンを押してください。

閉じる

※知恵コレクションに追加された質問は選択されたID/ニックネームのMy知恵袋で確認できます。

不適切な投稿でないことを報告しました。

閉じる