[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『集計用マクロ』(ゾーマ)
私が作成したフォルダ内にある特定のシート名の特定の範囲を集計する
マクロなのですが、最初はシート名が変わらないと思っていたのですが
人によってシート名を変更している場合があり、集計から漏れるときもありました。
シートの順番はかわらない+シートが一つの時であればシート名ではなく、シートの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 >
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
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
遅れましたが、ありがとうございます。
質問の件ですが
そういうことではありません。
変数pdのところで左から何番目のシートを処理するか聞いて
ただそこだけを処理する形です。
今はシート名を聞いてそのシートを処理していますが、
番号を聞いてその番号をそのままWorksheets()の括弧の中に入れたいという感じです。
(伝わるでしょうか・・・。)
cutcopymodeについてはお見込みの通りです^^;
(ゾーマ) 2018/10/10(水) 13:36
そこまで考えることができてるなら、詰まっている箇所がわかりません。
(もこな2) 2018/10/10(水) 21:43
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
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.