[[20181003142039]] 『集計用マクロ』(ゾーマ) ページの最後に飛ぶ

[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]

 

『集計用マクロ』(ゾーマ)

私が作成したフォルダ内にある特定のシート名の特定の範囲を集計する
マクロなのですが、最初はシート名が変わらないと思っていたのですが
人によってシート名を変更している場合があり、集計から漏れるときもありました。
シートの順番はかわらない+シートが一つの時であればシート名ではなく、シートのn番目を参照できるようにして
Worksheets(1)みたいにすれば解決すると思ったのですが
いまいちどこを換えれば良いか分かりませんでしたので質問させていただきます。

※ユーザーフォームも勉強しようとしてユーザーフォームもはいってます。
※私的にはSheets(pd).Range(pa & ":" & pb).Copy
のSheetsをworksheetsにすればよいと思ってますが。。。

以下コード

Public pa As String, pb As String, pc As String, pd As String, pe As String
Private folder As String, buf As String, ws As Worksheet, flag As Boolean

Sub 選択ver()

 With Application.FileDialog(msoFileDialogFolderPicker)
 .Title = "*** フォルダを選択し、[OK]をクリック ***"
 If .Show = True Then
 folder = .SelectedItems(1)
 Else
 Exit Sub
 End If
 End With
 '集計フォルダを選択
 UserForm1.Show
'ユーザーフォーム呼び出し
End Sub
Sub macro2()

Worksheets().Add After:=Worksheets(Worksheets.Count)
'2つ3つ出来なくなるのであえて名前は付けない

 Application.ScreenUpdating = False
'画面停止
buf = Dir(folder & "\*.xls*")
 Do While buf <> ""
 Workbooks.Open folder & "\" & buf
 '集計先のシート名をシートに記載。 範囲をRangeで
 For Each ws In Worksheets
    If ws.Name = pd Then flag = True
 Next ws
'シート名があるか調べる
 If flag = True Then 'あるなら実行
 Sheets(pd).Range(pa & ":" & pb).Copy
 ThisWorkbook.Activate
 'Range(A・・・。っていうのが貼り付ける基準となる列。offset(3,0)が貼り付ける行間。
 ActiveSheet.Range("A65536").End(xlUp).Offset(pe, 0).PasteSpecial Paste:=xlPasteValues '値貼り付け
 Workbooks(buf).Activate
 Application.CutCopyMode = False
 End If
 Workbooks(buf).Close SaveChanges:=False
 buf = Dir()
 Loop

 If pc <> "" Then
  Range(pc & ":" & pc).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
 End If
 '余分な範囲まで設定したときのために空白列削除
 Application.ScreenUpdating = True
 '画面再開
 MsgBox "終了しました。"

End Sub

Private Sub CommandButton1_Click()

'列 ◯◯ 改行 行◯◯ シート名 ◯◯ でよろしいですか?のメッセージぼっくす
pa = TextBox1.Value
pb = TextBox2.Value
pc = TextBox3.Value
pd = TextBox4.Value
pe = TextBox5.Value

Rtn = MsgBox("集計範囲 " & pa & ":" & pb & vbCrLf & _

             "集計するシート名 " & pd & vbCrLf & _
             "貼り付けする行 " & pe & "行" & vbCrLf & _
             pc & "列が空欄なら行消去" & vbCrLf & _
             "でよろしいですか?", vbYesNo)

    If Rtn = vbNo Then Exit Sub

Unload Me
End Sub
Private Sub CommandButton2_click()
If MsgBox("中止しますか?", vbYesNo) = vbYes Then
End
End If
End Sub

Private Sub Userform_queryclose(Cancel As Integer, closemode As Integer)

    If closemode = vbFormControlMenu Then 'vbformcontrolmenuは0でもよい
        MsgBox "中止ボタンで戻ってね"
        Cancel = True
    End If

    If closemode = vbFormCode Then 'vbformcodeは1でもよい
        Call macro2
    End If

End Sub

< 使用 Excel:Excel2013、使用 OS:Windows7 >


pdという変数にシート名が入っているようですが、これを書き換えては駄目でしょうか? 変えると困る、という場合は、以下とか。
 If flag = True Then 'あるなら実行
    Sheets(pd).Range(pa & ":" & pb).Copy
 Else
    Sheets(1).Range(pa & ":" & pb).Copy
 End If

なお、CutCopyMode プロパティを操作した後の End If 文は不要になります。

(???) 2018/10/03(水) 15:00


インデントがないし、コメントが変な場所にあるので見づらいな〜とおもったので、ちょこっと整理。
(ユーザーフォームを再現するのがめんどくさかったので、動作チェック&コンパイルチェックはしてないのでミスがあったらごめんなさい)

【標準モジュール】
 Option Explicit

    Private folder As String

    Sub 選択ver()

        '集計フォルダを選択
        With Application.FileDialog(msoFileDialogFolderPicker)
            .Title = "*** フォルダを選択し、[OK]をクリック ***"
            If .Show = True Then
                folder = .SelectedItems(1)
            Else
                Exit Sub
            End If
        End With

        UserForm1.Show 'ユーザーフォーム呼び出し

    End Sub
 '
 '
 '
    Sub macro2()
        Dim buf As String '←このプロシージャでしか使わないから、ここで宣言
        Dim ws As Worksheet, flag As Boolean '← 同上
        Dim dstSH As Worksheet

        'Application.ScreenUpdating = False '画面更新停止 ←安定動作確認するまではコメントアウトを推奨
        Set dstSH = Worksheets.Add(After:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count))

        buf = Dir(folder & "\*.xls*")
        Do While buf <> ""
            With Workbooks.Open(folder & "\" & buf)
                '開いたブックの各シートを順番に処理
                For Each ws In Worksheets
                    'シート名が「pd」と一致するか判定して、一致した場合だけ追加したシートに値貼付
                    If ws.Name = pd Then
                        ws.Range(pa & ":" & pb).Copy
                        dstSH.Cells(dstSH.Rows.cout, "A").End(xlUp).Offset(pe, 0).PasteSpecial Paste:=xlPasteValues
                    End If
                Next ws

                .Close SaveChanges:=False
            End With
        Loop

        '余分な範囲まで設定したときのために空白列削除
        If pc <> "" Then
            Range(pc & ":" & pc).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
        End If

        Application.ScreenUpdating = True '画面更新再開
        MsgBox "終了しました。"

    End Sub

【UserForm1のモジュール】
 Option Explicit 
 Public pa As String, pb As String, pc As String, pd As String, pe As String

    Private Sub CommandButton1_Click()
        '列 ◯◯ 改行 行◯◯ シート名 ◯◯ でよろしいですか?のメッセージぼっくす
        pa = TextBox1.Value
        pb = TextBox2.Value
        pc = TextBox3.Value
        pd = TextBox4.Value
        pe = TextBox5.Value
        Rtn = MsgBox("集計範囲 " & pa & ":" & pb & vbCrLf & _
                   "集計するシート名 " & pd & vbCrLf & _
                   "貼り付けする行 " & pe & "行" & vbCrLf & _
                   pc & "列が空欄なら行消去" & vbCrLf & _
                   "でよろしいですか?", vbYesNo)
          If Rtn = vbNo Then Exit Sub
        Unload Me
    End Sub
 '
 '
 '
    Private Sub CommandButton2_click()
        If MsgBox("中止しますか?", vbYesNo) = vbYes Then End
    End Sub
 '
 '
 '
    Private Sub Userform_queryclose(Cancel As Integer, closemode As Integer)
        If closemode = vbFormControlMenu Then 'vbformcontrolmenuは0でもよい
            MsgBox "中止ボタンで戻ってね"
            Cancel = True
        End If
        If closemode = vbFormCode Then 'vbformcodeは1でもよい
            Call macro2
        End If
    End Sub

とりあえず、気になるところを修正しながら、インデント&コメント付け直すとこんな感じでしょうか。

その上で、質問の
>順番はかわらない+シートが一つの時であれば
という条件がわからないのですが、シートが1つだけなら、順番の変わりようが無いですよね、
(常に1番目のシートでしょうから、おっしゃるとおりWorksheets(1)でつかめます。)

なので、もしかして、
・シートが1つだけの場合 → そのシートを処理
・シートが順番どおり(ベースとなるシートの順番があって、判定の結果並び順が一致したら)→そのシート群を処理
ということでしょうか?

ちなみに、CutCopyMode の操作ってループの中で繰り返してますけど、ループの終わりに1回だけやれば十分でしょうし、もっと言えばどうせ保存せずにブック閉じるから、解除する必要すら無いような・・

(もこな2) 2018/10/03(水) 23:20


もなこ2さま

遅れましたが、ありがとうございます。

質問の件ですが
そういうことではありません。
変数pdのところで左から何番目のシートを処理するか聞いて
ただそこだけを処理する形です。

今はシート名を聞いてそのシートを処理していますが、
番号を聞いてその番号をそのままWorksheets()の括弧の中に入れたいという感じです。
(伝わるでしょうか・・・。)
cutcopymodeについてはお見込みの通りです^^;

(ゾーマ) 2018/10/10(水) 13:36


たぶん私あてのレスなのでコメントしますが、
>変数pdのところで左から何番目のシートを処理するか聞いて
ただそこだけを処理する形です。
>そのままWorksheets()の括弧の中に入れたいという感じです。
それなら、そうすればいいのでは?

そこまで考えることができてるなら、詰まっている箇所がわかりません。
(もこな2) 2018/10/10(水) 21:43


変数pdの宣言をString型(文字列型)からInteger型(整数型)に変更して、
macro2の Do While buf <> "" 〜 Loop までを下記のようにしたらどうでしょうか?

Do While buf <> ""

    Workbooks.Open folder & "\" & buf
    '↓pdがブックbufのシート数以下なら処理
    If pd <= Workbooks(buf).Sheets.Count Then
        Workbooks(buf).Sheets(pd).Range(pa & ":" & pb).Copy
        ThisWorkbook.Activate
        ActiveSheet.Range("A65536").End(xlUp).Offset(pe, 0).PasteSpecial Paste:=xlPasteValues
        Workbooks(buf).Activate
        Application.CutCopyMode = False
    Else
        MsgBox buf & "には" & pd & "枚目のシートはないよ(^^;"
    End If
    Workbooks(buf).Close SaveChanges:=False
    buf = Dir()
Loop

質問の内容を読み違えていたらすみません(^^;
(虎) 2018/10/11(木) 09:41


すみません。
頭固くて難しく考えてしまったようです
もなこさま虎様
ありがとうございました^^;
(ゾーマ) 2018/10/16(火) 09:53

コメント返信:

[ 一覧(最新更新順) ]


YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki. Modified by kazu.