VBA 条件式の質問とは?新たなフォルダを指定すると処理が変わるマクロ

このQ&Aのポイント
  • 初心者に近い者がVBAの条件式について質問します。指定したフォルダ内のCSVファイルを連結し、特定のセルを別シートに貼り付けるマクロを作成中です。
  • 実行すると、ダイアログが表示され、指定したフォルダ内のCSVファイルを処理します。マクロ内のCase文を使用し、特定のセルに貼り付ける箇所を指定しています。
  • 質問の主要部分は、新たなフォルダを指定すると特定のセルに貼り付ける箇所が変わるような条件式の作り方です。具体的には、A-TESTフォルダを指定すると処理2の欄を実行し、B-TESTフォルダを指定すると別の箇所に貼り付けるようにしたいとのことです。
回答を見る
  • ベストアンサー

VBA 条件式のことで質問です。。

はじめましてほぼ初心者に近い者なのですが VBAの条件式のことで質問がありまして ※ コードの内容はgooで回答いただいていたコードを使わせてもらい、少しだけ変更したものです。申し訳ありません。 以下のマクロ '----------------------------------------------------------- Sub CSV_READ() Dim MyObj As Object Dim MyFol As String Dim MyFnm As String Dim MyStr As String Dim i As Long Dim n As Long Dim n1 As Long 'フォルダを選択する Set MyObj = CreateObject("Shell.Application") _ .BrowseForFolder(0, "SelectFolder", 0) '選択なければ処理を抜ける If MyObj Is Nothing Then Exit Sub MyFol = MyObj.self.Path & "\" MsgBox MyFol & "を処理します。" Set MyObj = Nothing Application.ScreenUpdating = False 'データ読み込みシートを選択 Sheets("ツール").Select With Sheets("ツール") 'Dir関数を使って指定フォルダ内csvファイルを順次処理 MyFnm = Dir(MyFol & "*.csv") Do Until Len(MyFnm) = 0& i = i + 1 'データエリアを取得してセット先を変更 n = IIf(n = 0, 1, n + n1) '外部データ取り込みを利用 With .QueryTables.Add(Connection:="TEXT;" & MyFol & MyFnm, _ Destination:=.Range("A" & n)) .AdjustColumnWidth = False .TextFilePlatform = xlWindows .TextFileStartRow = 2 .TextFileCommaDelimiter = True .Refresh False n1 = .ResultRange.Rows.Count .Parent.Names(.Name).Delete .Delete End With '次のファイルへ MyFnm = Dir() Loop End With If i > 0 Then MyStr = i & "個のファイルを処理しました。" Else '検索結果が0なら MyStr = "検索条件を満たすファイルはありません。" End If '------------------------------------------------------------------- '処理2 '------------------------------------------------------------------- ' 別シートに反映 Range("M2:M3020").Select Selection.Copy Sheets("Sheet2").Select Range("C4").Select ActiveSheet.Paste Sheets("Sheet1").Select Range("E2:E3020").Select Selection.Copy Sheets("Sheet2").Select Range("D4").Select ActiveSheet.Paste Sheets("Sheet1").Select Range("F2:F3020").Select Selection.Copy Sheets("Sheet2").Select Range("E4").Select ActiveSheet.Paste Sheets("Sheet1").Select Range("C2:C3020").Select Selection.Copy Sheets("Sheet2").Select Range("G4").Select ActiveSheet.Paste Application.ScreenUpdating = True MsgBox MyStr End Sub '----------------------------------------------------------- 以上 '----------------------------------------------------------- こちらを実行するとダイアログが出現しCSVファイルのみが格納されているフォルダまで進め、 フォルダ指定することで中のCSVファイルの中身のセルを全てを連結させて表示し 指定行だけをコピーして別シートの指定セルに貼り付けするという繰り返しマクロなのですが、 私が知りたいことは CSVファイルが格納されているフォルダ A-TESTフォルダ B-TESTフォルダ C-TESTフォルダ D-TESTフォルダ というように A-TESTフォルダを指定すると上の処理2欄を実行し B-TESTフォルダを選択すると ("C4")←貼り付け先を("E4")にする。 ("D4")の箇所を⇒("F4")に。 というような感じのCase文?で作ることができる条件式をご教授頂きたいのですが 書き方に行き詰ってしまい困っております。 どこか説明不足や、質問内容がわかりにくいかもしれません。。。。 長々となってしまいお手数お掛けしますがご意見お待ちしております。 よろしくお願いします。

質問者が選んだベストアンサー

  • ベストアンサー
  • kokorone
  • ベストアンサー率38% (417/1093)
回答No.1

いろいろな方法があるかと思いますが、 できる限り、同じ処理を記述しないよう、貼り付け先を変数にしてみました。 Dim Pasterange1 As String Dim Pasterange2 As String Select Case MyFol Case "A-TEST" Pasterange1 ="C4" Pasterange2 ="D4" Case "B-TEST" Pasterange1 ="E4" Pasterange2 ="F4" Case "C-TEST" Pasterange1 ="G4" Pasterange2 ="H4" End Select '処理2改良 別シートに反映 Range("M2:M3020").Select Selection.Copy Sheets("Sheet2").Select Range(Pasterange1).Select ActiveSheet.Paste Sheets("Sheet1").Select Range("E2:E3020").Select Selection.Copy Sheets("Sheet2").Select Range(Pasterange2).Select ActiveSheet.Paste Sheets("Sheet1").Select Range("F2:F3020").Select Selection.Copy Sheets("Sheet2").Select Range("E4").Select ActiveSheet.Paste Sheets("Sheet1").Select Range("C2:C3020").Select Selection.Copy Sheets("Sheet2").Select Range("G4").Select ActiveSheet.Paste Application.ScreenUpdating = True MsgBox MyStr End Sub

pou1986
質問者

お礼

返事遅くなりました。 上記の貼り付け先を変数に変えて試してみたのですが Range(Pasterange1).Select の箇所で 'Range' メソッドに失敗しました:'_Global'オブジェクト とゆうエラーが発生しまして 対処方法に困っています><; すいません。。もう一度ご教授お願います;;

関連するQ&A

  • エクセル VBA 繰り返し コピー貼り付け

    以下を繰り返し作業をOffsetを使用して行いたいのですがどうすればいいでしょうか? Sheets("Sheet1").Select Range("A1:C1").Select のA1:C1以下へA1000:C1000ぐらいあります。 Sheets("Sheet2").Select Range("G1").Select は貼り付けたセル3つの数字の組み合わせで公式に使う計算期間がまちまちですので公式を張り付けたり出来ません。 D1の解を heets("Sheet1").Select Range("D1").Select に貼り付けてA1:C1以下1000までの結果を評価出来るようにしたいのですが! ' Macro1 Macro Sheets("Sheet1").Select Range("A1:C1").Select Selection.Copy Sheets("Sheet2").Select Range("D1").Select ActiveSheet.Paste Range("G1").Select Application.CutCopyMode = False Selection.Copy Sheets("Sheet1").Select Range("D1").Select ActiveSheet.Paste Range("A2:C2").Select Application.CutCopyMode = False Selection.Copy Sheets("Sheet2").Select Range("D1").Select ActiveSheet.Paste Range("G1").Select Application.CutCopyMode = False Selection.Copy Sheets("Sheet1").Select Range("D2").Select ActiveSheet.Paste Range("A3:C3").Select Application.CutCopyMode = False Selection.Copy Sheets("Sheet2").Select Range("D1").Select ActiveSheet.Paste Range("G1").Select Application.CutCopyMode = False Selection.Copy Sheets("Sheet1").Select Range("D3").Select ActiveSheet.Paste End Sub よろしくおねがいします。

  • CSV

    複数の定型フォームのCSVファイルを1エクセルファイルにして、エクセル上で集計まで行いたいと思っています。 今、「教えて!goo」から検索で、VBAを使って、CSVファイルをエクセルの1シートにまとめることはできたのですが、 ・シート名を特定の名前にしたい ・同ファイル内の、既存の「TTL」というシート上で合計を表示させたい のですが、シート名が定まらないので設定ができません。 どうか、設定方法を教えてください。 VBA式は以下のとおり ↓↓↓ Dim MyObj As Object Dim MyFol As String Dim MyFnm As String Dim MyStr As String Dim i As Long Dim n As Long Dim n1 As Long 'フォルダを選択する Set MyObj = CreateObject("Shell.Application") _ .BrowseForFolder(0, "SelectFolder", 0) '選択なければ処理を抜ける If MyObj Is Nothing Then Exit Sub MyFol = MyObj.self.Path & "\" MsgBox MyFol & "を処理します。" Set MyObj = Nothing Application.ScreenUpdating = False 'ThisWorkbookにシートを追加して処理 With Sheets.Add 'Dir関数を使って指定フォルダ内csvファイルを順次処理 MyFnm = Dir(MyFol & "*.csv") Do Until Len(MyFnm) = 0& i = i + 1 'データエリアを取得してセット先を変更 n = IIf(n = 0, 1, n + n1) '外部データ取り込みを利用 With .QueryTables.Add(Connection:="TEXT;" & MyFol & MyFnm, _ Destination:=.Range("B" & n)) .AdjustColumnWidth = False .TextFilePlatform = xlWindows .TextFileStartRow = 1 .TextFileCommaDelimiter = True .Refresh False n1 = .ResultRange.Rows.Count .Parent.Names(.Name).Delete .Delete End With 'ファイル名をA列にセット .Range("A" & n).Resize(n1).Value = MyFnm '次のファイルへ MyFnm = Dir() Loop End With If i > 0 Then MyStr = i & "個のファイルを処理しました。" Else '検索結果が0なら MyStr = "検索条件を満たすファイルはありません。" End If Application.ScreenUpdating = True MsgBox MyStr

  • VBA 最終行を選んだシートにコピーする。

    VBAど初心者です。どうしても最終行のデータを選んだシートにコピーできません。 LastRow.Selectのところで、止まってしまいます。どのように行を設定していいのかさっぱりわかりません。どなたか、ご指導のほどよろしくお願いします。 Sub copy_last_line() Dim LastRow As Long Sheets("Sheet1").Select LastRow = Cells(Rows.Count, 1).End(xlUp).Row LastRow.Select Selection.Copy Sheets("Sheet2").Select Range("A1").Select ActiveSheet.Paste Sheets("Sheet1").Select Range("A1").Select End Sub

  • エクセルVBA-カウンター i と j の使い方

    2つの条件を同時に満たすと図形を別のワークシートにコピーし、600行程度あるワークシートなので For - Next を使ってその作業を繰り返す、というエクセルのマクロを以下のように書き込みました。ところがマクロを実行すると、一番最初の行だけ正確に実行され、次に条件を満たす行があっても図形がコピーされません。(ということはカウンター i, j の使い方が間違っているのです)どなたか私の素人コードを見て修正方法を教えてください。お願いします。 Sub finalize() Dim MyStr As String Dim i As Long Dim j As Long  For j = 2 To 1482 Step 40 For i = 3 To 188 Step 5 MyStr = Range("O" & i) If MyStr <> "" Then                    '条件1 If Range("L" & i).Value = "毎日" Then      '条件2   Sheets("図形_現読").Select ActiveSheet.Shapes.Range(Array("毎日")).Select Selection.Copy Sheets("印刷画面").Select Range("AG" & j).Select ActiveSheet.Paste Else If Range("L" & i).Value = "朝刊" Then Sheets("図形_現読").Select ActiveSheet.Shapes.Range(Array("朝刊")).Select Selection.Copy Sheets("印刷画面").Select Range("AG" & j).Select ActiveSheet.Paste End If End If End If Next i Next j End Sub

  • エクセルマクロVBAについて

    エクセルマクロVBAについて、こんなこと出来ますか? ■A列からAS列の1行目にヘッダー情報をもつデータベース ■A列に担当者名 ■A列にオートフィルタをかけて各担当ごとにデータを抽出したものを別シートに貼り付けて自動印刷したい ■担当者は都度変わるので、Criteria1:="xxx"というようには直接書けない(担当名を自動で抽出したい) ■担当者の数も都度変わる ■補足 一行のデータを特定の雛形に転記する必要があるので別シートに出したいです ちなみに、アナログで記録したコードは以下です。 Sub test1() Sheets("データ抽出シート").Select ActiveSheet.Range("$A$1:$AS$300").AutoFilter Field:=1, Criteria1:="山田" Range("$A$1:$AS$300").Select Selection.Copy Sheets("抽出データ貼付シート").Select Range("A1").Select Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False ActiveWindow.SelectedSheets.PrintOut Copies:=1 Sheets("データ抽出シート").Select ActiveSheet.Range("$A$1:$AS$300").AutoFilter Field:=1, Criteria1:="斉藤" Range("$A$1:$AS$300").Select Selection.Copy Sheets("抽出データ貼付シート").Select Range("A1").Select Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False ActiveWindow.SelectedSheets.PrintOut Copies:=1 Sheets("データ抽出シート").Select ActiveSheet.Range("$A$1:$AS$300").AutoFilter Field:=1, Criteria1:="田中" Range("$A$1:$AS$300").Select Selection.Copy Sheets("抽出データ貼付シート").Select Range("A1").Select Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False ActiveWindow.SelectedSheets.PrintOut Copies:=1 End Sub これ、担当者の抽出を自動でなんとかなりませんか?

  • エクセルVBAについての質問です。

    エクセルVBAについての質問です。  動作環境は  OS:WINDOWS XP  エクセル2003  です。 今、Book1.xlsというエクセルファイルがあります。 このファイルの中に、【sheet1】,【sheet2】,【sheet3】の3つのシートが存在しています。 【sheet1】および【sheet2】には、A列=ユニーク番号、B列=データ1、C列=データ2・・・・n列=データnの値が約1500行(各行で、データの値は異なります。)入っています。 この【sheet1】と【sheet2】のデータの内容を照合して【sheet3】にその結果を反映(TRUEまたはFALSE)します。 仮に【sheet3】のあるセル(仮にD3)の値がTRUEとなったら、【sheet1】のセル(D3)の値を【sheet3】のセル(D3)に代入する。 逆に【sheet3】のあるセルの値がFALSEとなったら、そのセルはFLASEのままにする。プログラムは以下の様にしたのですが、全てを処理するまでに相当時間がかかっています。 VBAのプログラムは今回初めて書いたので、プログラムが悪いのか、プログラムの思想が悪いのかがわかりません。 どなたかご教授していただけませんか?多分、コードの書き方もキレイではないと思います(悲) Private Sub データ照合ボタン_DblClick(ByVal Cancel As MSForms.ReturnBoolean) Dim i As Long Dim area As Range Dim A As Variant Dim WrkRange As String '----シート(1)とシート(2)の各セルの値を比較---- With Sheets("sheet1") WrkRow = .Cells(Rows.Count, 3).End(xlUp).Row End With Sheets("sheet3").Select For i = 12 To WrkRow WrkRange = Range("C" & i).Select ActiveCell.FormulaR1C1 = "=EXACT('sheet1'!RC,'sheet2'!RC)" WrkRange = Range("D" & i).Select ActiveCell.FormulaR1C1 = "=EXACT('sheet1'!RC,'sheet2'!RC)" '・           '・           '・ Next i A = i - 1 Sheets("sheet1").Select For i = 12 To A WrkRange = Range("C" & i).Select Selection.Copy Range("C" & i).PasteSpecial xlPasteValues Sheets("sheet3").Select If Range("C" & i) = True Then Sheets("sheet1").Select Range("C" & i).Copy Sheets("sheet3").Select Range("C" & i).Select ActiveSheet.Paste Else: End If Next i A = i - 1 Sheets("sheet1").Select For i = 12 To A WrkRange = Range("D" & i).Select Selection.Copy Range("D" & i).PasteSpecial xlPasteValues Sheets("sheet3").Select If Range("D" & i) = True Then Sheets("sheet1").Select Range("D" & i).Copy Sheets("sheet3").Select Range("D" & i).Select ActiveSheet.Paste Else: End If Next i          '・          '・          '・    End Sub

  • EXCELのVBAについて

    マクロのボタンで内容を削除する様に設定した所、 Dim re As Integer Sheets("投入シート").Select re = MsgBox("入力データをクリアします。" & vbCrLf & vbCrLf & "よろしいですか?", vbOKCancel, "クリア確認") If re <> vbCancel Then Sheets("投入シート").Select ActiveSheet.Unprotect Range("a1:c30").Select Selection.Copy Application.CutCopyMode = False Selection.Copy Sheets("work").Select Range("A1").Select ActiveSheet.Paste Sheets("投入シート").Select ActiveSheet.Unprotect Range("c4:c30").Select Selection.ClearContents Range("f31").Select Selection.Copy Range("c9").Select ActiveSheet.Paste Range("f33").Select Selection.Copy Range("c11").Select ActiveSheet.Paste Range("f32").Select Application.CutCopyMode = False Selection.Copy Range("c14").Select ActiveSheet.Paste Range("c4").Select Application.CutCopyMode = False 'ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True End If Sheets("投入シート").Select Range("c4").Select End Sub この様に入力したのですがセルのC11の計算式だけセル番号が消えてしまいます。 どうしてでしょうか?ご指導をお願いします。

  • Excel VBA連続コピー、貼付処理について

    特定のフォルダ内に格納されている複数のExcelファイルの「sheet1」シートのデータを 所定のExcelファイルにコピー&ペーストしたいのですが、うまくいきません。 (貼付先のファイルを閉じようとするとエラーが発生します。) どうすればできるようになるでしょうか? ご教授の程よろしくお願いいたします。 -------------------------------------------------------------------- Sub copy_test() Dim myPath As String Dim copyFile As String Dim pasteFile As String Dim n As Long myPath = "C:\copy\" copyFile = Dir(myPath & "*.xls*") pasteFile = "C:\paste\paste_data.xlsx" n = 2 Do Until copyFile = "" Workbooks.Open Filename:=myPath & copyFile Workbooks(copyFile).Worksheets("sheet1").Range("A2:L201").Copy Workbooks.Open Filename:=pasteFile 'Workbooks(pasteFile).Worksheets("paste_data").Active Range("B1").Select Selection.End(xlDown).Select Selection.End(xlToLeft).Select Selection.End(xlUp).Select ActiveCell.Offset(1, 0).Select ActiveSheet.Paste ActiveWorkbook.Save Workbooks(pasteFile).Close False Application.CutCopyMode = False Workbooks(copyFile).Close False n = n + 999 copyFile = Dir() Loop End Sub ---------------------------------------------------------------------------------

  • EXCELのVBAを実行したら止まってしまいます。。。

    お世話になります。 下記のマクロを作ってみたのですが、シート「読込」にコピーされたところまで確認できるのですが、その後マウスが砂時計になって、動かなくなってしまいます。オートフィルタを解除する部分を削って実行してみましたが、同じところで止まりますので、貼付のところに問題があるようなのですが、何がいけないのでしょうか? また、なんかもっとスマートなプログラムになりませんでしょうか? 宜しくお願いします。 Sub test() Sheets("Normal").Select Range("A2").Select Selection.AutoFilter Field:=1, Criteria1:=Sheets("読込").Range("B2"), _ Operator:=xlAnd, Criteria2:=Sheets("読込").Range("C2") Selection.SpecialCells(xlVisible).Copy Sheets("読込").Select Range("C3").Select ActiveSheet.Paste Sheets("Normal").Select Application.CutCopyMode = False ActiveSheet.ShowAllData Selection.AutoFilter End Sub

  • 複数シートをループさせてマクロを簡素化したい

    win7 Excel2007 でマクロ作成中の初心者です。 シート数の変動する複数シートの特定範囲を一枚のシートに右列方向に、値を貼り付けたいです。 自動記録でコード作成しましたが、もっと簡素化して軽くしたいです。 シートに対するループ等の作成ができません。どうかご指導お願いします。 Sub 勤怠最終データ作成() Worksheets(1).Select '1番左のシートを選択 ActiveSheet.Unprotect Range("B29:BM60").Select '複写範囲はすべて同じ Selection.Copy Sheets("総括").Select '値の貼り付けシートはすべて同じ Range("A2").Select '値の貼り付け先 Selection.PasteSpecial Paste:=xlPasteValues ’-------------------------------------- Worksheets(2).Select '2枚目のシートを複写 ActiveSheet.Unprotect Range("B29:BM60").Select Selection.Copy Sheets("総括").Select 最終セルの選択 '値の貼り付け先 Selection.PasteSpecial Paste:=xlPasteValues ’-------------------------------------- Worksheets(3).Select '3枚目のシートを複写 ActiveSheet.Unprotect Range("B29:BM60").Select Selection.Copy Sheets("総括").Select 最終セルの選択 Selection.PasteSpecial Paste:=xlPasteValues ’-------------------------------------- Worksheets(4).Select '4枚目のシートを複写 ActiveSheet.Unprotect Range("B29:BM60").Select Selection.Copy Sheets("総括").Select 最終セルの選択 Selection.PasteSpecial Paste:=xlPasteValues 以下省略 End Sub