• 締切済み

これのおかしいところはありますか？エクセル B列

Option Explicit Sub ExtractColumnB() Dim FolderPath As String Dim FileName As String Dim SourceWorkbook As Workbook Dim TargetWorkbook As Workbook Dim SourceWorksheet As Worksheet Dim TargetWorksheet As Worksheet Dim LastRow As Long Dim TargetLastRow As Long ' 対象フォルダの選択 With Application.FileDialog(msoFileDialogFolderPicker) .Title = "フォルダを選択してください" .AllowMultiSelect = False If .Show <> -1 Then Exit Sub FolderPath = .SelectedItems(1) End With ' 出力用ワークブックとワークシートを作成 Set TargetWorkbook = Workbooks.Add Set TargetWorksheet = TargetWorkbook.Worksheets(1) ' 対象フォルダ内のExcelファイルを順次処理 FileName = Dir(FolderPath & "\*.xls*") Do While FileName <> "" ' ソースファイルを開く Set SourceWorkbook = Workbooks.Open(FolderPath & "\" & FileName) Set SourceWorksheet = SourceWorkbook.Worksheets(1) ' B列のデータを抽出 LastRow = SourceWorksheet.Cells(Rows.Count, 2).End(xlUp).Row ' 抽出したデータを出力用ワークシートにコピー TargetLastRow = TargetWorksheet.Cells(Rows.Count, 2).End(xlUp).Row + 1 SourceWorksheet.Range("B1:B" & LastRow).Copy TargetWorksheet.Range("B" & TargetLastRow) ' ソースファイルを閉じる SourceWorkbook.Close SaveChanges:=False ' 次のファイルへ FileName = Dir Loop ' 確認メッセージ MsgBox "B列のデータ抽出が完了しました。", vbInformation End Sub

みんなの回答

回答No.1

このれは（VBAを使用して）Excelファイルの複数のファイルからB列のデータを抽出し、新しいExcelファイルにコピーすることを目的としたものですね。 “ VBAでデータ転記する方法とは？5つのサンプルを使って解説！“ https://www.sejuku.net/blog/94349 “ エクセルマクロVBAでデータ項目別にシートコピーし自動転記“ https://fastclassinfo.com/entry/vba_sheet_tenki/ このコードには、明らかな構文エラーは見当たりらないようですが、ファイルが存在しないとかや該当ファイルにB列のデータを含まないとかの場合などは、例外処理が不足する場合があるかもです。改善は以下のような点に考慮が必要かもです。 フォルダ選択ダイアログのキャンセルに対するエラー処理を追加する。 こうすることで、ユーザーがキャンセルボタンを押した場合などにエラーが発生しない対応ができるかもです。 ファイルが存在しない場合にはエラーになるかもなので、関数を使用する前に、指定されたフォルダにExcelファイルがあるかどうかを確認する必要があるかもです。 抽出するべきB列が存在しない場合、エラーが発生するかもなので、変数を使用する前に、B列にデータが存在するかどうかを確認する必要があります。コードを追加する必要があるかもです。 VBAのプログラムを半自動でチェックしてくれるサイトには↓のようなものがありますので、利用してみてください。 コードの品質・構文エラーチェック、最適化提案、および一貫性の維持などをやってくれるようです。ただ全てを自動的にやってくれるわけでないようなので、手動での確認も必要です・・・ VB Watch Code Analyzer: https://www.vbwatch.com/Products/CodeAnalyzer/ VBA Code Compare: https://www.vbacodecompare.com/ Rubberduck VBA: https://rubberduckvba.com/ こちらも参考に！ “ ExcelマクロVBA関数の一覧と解説“ https://excel-ubara.com/EXCEL/EXCEL903.html 「マクロ」「VBA」「excel」に関する質問と回答 https://okwave.jp/search?word=%E3%83%9E%E3%82%AF%E3%83%AD%E3%80%80VBA%20excel 良い方向に進みますように！ 参考になれば幸いです。

画像を拡大する
  1. カテゴリ
  2. パソコン・スマートフォン
  3. ソフトウェア
  4. Excel（エクセル）

関連するQ&A

  • vba　ファイルの移動について

    フォルダAの中にあるたくさんのpdfファイルの中から、 ファイル名の頭文字３つがE列に記載した「aaa」だったら フォルダBに移動させるという内容にしたいです。 ネット検索などで、近いものを作成しましたが（下に貼り付け）、 下から４行目、「fso.moveFile FolderA & "\" & fileName, FolderB & "\" & fileName」で 「実行時エラー'53'　　ファイルが見つかりません。」　とエラーが出てしまいます。 どの様に書き直せばよいのでしょうか？ どなたかご存じでしたら、ぜひお教え下さい。 よろしくお願いします。 エクセル2010を使用しています。 Sub CheckAndMoveFiles() Dim FolderA As String Dim FolderB As String FolderA = Range("D1").Value FolderB = Range("B2").Value Dim fso As Object Set fso = CreateObject("Scripting.FileSystemObject") Dim ws As Worksheet Set ws = ActiveSheet Dim lastRow As Long lastRow = ws.Range("E" & Rows.Count).End(xlUp).Row Dim r As Long Dim fileName As String For r = 1 To lastRow If ws.Cells(r, "E").Value <> "" Then fileName = ws.Cells(r, "E").Value dFileName = Dir(FolderA & "\" & Left(fileName, 3) & "*.pdf") Do While dFileName <> "" dFileName = Dir() Loop fso.moveFile FolderA & "\" & fileName, FolderB & "\" & fileName　'ここでストップ End If Next End Sub

  • フォルダ内の複数ブックのデータとブック名を転記する

    フォルダの中に複数のExcelファイル(ブック)が入っており、 それら全てのブックデータの転記を一括して行うマクロを現在使用しています。(後述) ＜現在の利用状況＞ ・フォルダの中に複数のExcelファイル(ブック)が入っている。ファイルにつきシートは1つ（ひな形は同じ） ・ファイルを確認するまでデータが何行入っているか分からない ・貼り付ける際はシートの上部は意図的に消している ＜改善希望＞ ・どのファイルから貼り付けたか分かるように、A列にファイル名を追記したい(どの行にも) ・できれば先頭の3文字のみ VBA勉強中の初心者ですが、なるべく早く実装しないといけないので、困っています。。。。 ご教示頂けます様お願いいたします。 ＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝ Sub データ集計() '集計シートを変数に格納 Dim ws As Worksheet Set ws = ActiveSheet '集計シートの最終行を取得 Dim LastRow As Long LastRow = ws.Cells(Rows.Count, 5).End(xlUp).Row MsgBox "このブックと同じフォルダにあるブックを全て統合します" 'このブックの保存されているフォルダのパス（番地;ディレクトリ）を変数に取得 Dim thisPath As String thisPath = ThisWorkbook.Path 'ディレクトリにあるExcelのファイル名を取得 Dim fileName As String fileName = Dir(thisPath & "\" & "*.xlsx") Dim i As Long 'ファイル名が無くなるまで繰り返す Do While fileName <> "" '開くワークブックを変数に代入 Dim bufBook As Workbook Set bufBook = Workbooks.Open(thisPath & "\" & fileName) '開いたブックの第1シートの全データ --> 集計シートの最終行 bufBook.Worksheets(1).Range("B14").CurrentRegion.Copy Destination:=ws.Range("B" & LastRow) '最初のループ以外では、タイトル行を削除しておく Dim LastRowSecond As Long LastRowSecond = LastRow + 13 If i > 0 Then ws.Rows(LastRow & ":" & LastRowSecond).Delete End If '開いたブックを閉じる bufBook.Close SaveChanges:=False '集計シートの最終行を再取得しておく LastRow = ws.Cells(Rows.Count, 7).End(xlUp).Row + 1 '次のファイル名が取り出される。 fileName = Dir() i = i + 1 Loop End Sub

  • Excelのブック間の串刺し計算について

    Excelのブック間の串刺し計算について VBA超初心者です。同じフォルダ内にファイルがいくつかあり、同じ形式で、sheet1のB4のセルに計があったとして、それをブック間で串刺し集計したいのですが、うまくいきません。どこが悪いのかもわからず、困り果ててます。ご指導お願いします。 Sub BookShuukei() Dim FileName As String Dim Total As Integer Dim OpenedBook As Workbook Dim IsBookOpen As Boolean FileName = Dir("*.xls") Application.ScreenUpdating = False Do While FileName <> "" If FileName <> ThisWorkbook.Name Then IsBookOpen = False For Each OpenedBook In Workbooks If OpenedBook.Name = FileName Then IsBookOpen = True Exit For End If Next If IsBookOpen = False Then Workbooks.Open (FileName) End If Total = Total + Workbooks(FileName).Sheets(1).Range("B4").Value If IsBookOpen = False Then Workbooks(FileName).Close End If End If FileName = Dir() Loop Application.ScreenUpdating = True MsgBox (Total) End Sub

  • 複数のエクセルシートをまとめるマクロ

    下は複数のエクセルファイルを一つにするマクロですが、100万件を超えるためcsvで保存するようにするにはどこを変更したらよいでしょうか。 よろしくお願いします。 Sub Sample() Dim t As Single Dim strPath As String Dim strFileName As String Dim WB1 As Workbook Dim WS1 As Worksheet Dim WS2 As Worksheet Dim lngRowCount As Long 'A列に値が入っているデータ数 t = Timer 'まとめたいシート Set WS2 = ThisWorkbook.Worksheets(1) strPath = ThisWorkbook.Path strFileName = Dir(strPath & "\*.xls*") Do While strFileName <> "" If strFileName <> ThisWorkbook.Name Then Set WB1 = Workbooks.Open(strPath & "\" & strFileName) Set WS1 = WB1.Worksheets(1) With WS1.Range("A1") lngRowCount = .Worksheet.Cells(.Worksheet.Rows.Count, .Column).End(xlUp).Row - .Row If lngRowCount >= 1 Then With .Resize(lngRowCount, 14).Offset(1) .Copy WS2.Range("A" & WS2.Rows.Count).End(xlUp).Offset(1) End With End If End With WB1.Close False End If strFileName = Dir Loop MsgBox "まとめ処理をしました。処理時間 " & Format((Timer - t) / 60 / 60 / 24, "h:mm:ss") End Sub

  • エクセル　検索コピーマクロ

    マクロで検索、抽出して別ファイルに保存したいのですが、 以下のようなマクロを教えてもらったのですが コピー先のセル位置を任意の位置に直したいのですが、 どうしてもわかりません どの部分をどう直せばよいのでしょうか？ Option Explicit Sub copyTodayData() Dim dateToday As String Dim tempDate As String Dim lastrow1 As Long Dim lastrow2 As Long Dim i As Long Dim fileA As String Dim anotherBook As String Dim anotherFilePath As String fileA = ThisWorkbook.Name anotherBook = "別のファイル.xls" anotherFilePath = "C:\Documents and Settings\日本太郎\デスクトップ\どこかのフォルダ" '問い合せダイアログの表示をOFFにします Application.DisplayAlerts = False 'ファイルを開く ChDir anotherFilePath Workbooks.Open Filename:=anotherFilePath & "\" & anotherBook '問い合せダイアログの表示をONに戻します Application.DisplayAlerts = True 'ウインドウの切替 Windows(fileA).Activate '今日の日付を取得 dateToday = Date 'データ最終行を取得 lastrow1 = Cells(Rows.Count, 1).End(xlUp).Row For i = 2 To lastrow1 If Cells(i, 1) = dateToday Then 'Range(Cells(i, 1), Cells(i, 4)).Copy 'コピー Windows(anotherBook).Activate 'ウインドウの切替 lastrow2 = Cells(Rows.Count, 1).End(xlUp).Row '別ブックの最終行 Cells(lastrow2 + 1, 1).Select ActiveSheet.Paste Windows(fileA).Activate 'ウインドウの切替 End If Next i MsgBox "実行しました" End Sub たぶん、lastrow2 = Cells(Rows.Count, 1).End(xlUp).Row '別ブックの最終行 Cells(lastrow2 + 1, 1).Select ここらへんというのは、わかりますが、 どこをどう変えたらいいかわかりません

  • Excel VBAで検索結果を新規ブックにコピー

    Excel VBAの質問です。 コンボボックスで選択した文字列とSheet1のＣ列の文字列が一致したら、 その行を新規ブックのSheet1にコピーしたいのですが、うまくできません。 新規ブックは開くのですが、データはコピーされていません。 既存ブックのSheet2にはコピーできるので、たぶん、新規ブックのSheet1へコピーという 命令がうまくかけていないのだと思います。 書籍やネットで調べてもよく分かりませんでした。 大変困っているので、どなたかご教授ください。よろしくお願いします。 元のSheet1は以下のようにデータが入力されています。 例えば、コンボボックスで「めがね」と選択されたら、1，4，5行目のC列と一致するので それらの行を新規ブックにコピーしたいのです。 A B C D ----------------------------- 1|10 10:00 めがね 保管中 2|11 12:00 衣服　　倉庫 3|12 13:00 自転車　保管中 4|13 11:00 めがね　保管中 5|14 13:00 めがね　倉庫 Private Sub Search_Click() Dim SearchWord As String Dim gyou As Long Dim word As String Dim LastRow As Long Dim count As Integer Dim baseBook As Workbook Dim newBook As Workbook Dim baseSheet As Worksheet Dim newSheet As Worksheet SearchWord = cmbsSyutokubutu_search.Text Set baseBook = ThisWorkbook Set baseSheet = baseB.Worksheets("Sheet1") baseSheet.Activate With Worksheets("Sheet1") count = 0 gyou = 4 LastRow = baseSheet.Cells(Rows.count, 5).End(xlUp).Row Set newB = Workbooks.Add Set newS = newBook.Worksheets("Sheet1") Do While Cells(gyou, 3) <> "" word = Cells(gyou, 3) If InStr(word, SearchWord) >= 1 Then Rows(gyou).Copy newBook.Cells(Rows.count, 1).End(xlUp).Offset(1, 0) End If gyou = gyou + 1 Loop End With End Sub

  • Excelのワークシートでのコンボボックスについて

    Excelのワークシートでコンボボックスを設定する方法を教えてください。 「フォームコントロール」と「ActiveXコントロール」の違いがわかりません。 添付の画像の通りコンボボックスに西暦を入力(別シートに入力済みの値を表示するように設定)してあるのですが、ファイルを保存しているにも関わらず、再度ファイルを開くとコンボボックスの中のリストは空欄になってしまいます。 今は「ActiveXコントロール」のコンボボックスで設定しています。 コードは以下のように設定してみたのですが、設定内容や設定箇所が違うのでしょうか？ ////////////////////////////////////////////////////// Private Sub ComboBox1_DropButtonClick() Dim sh As Worksheet Set sh = Worksheets("マクロ") Dim i As Integer Dim lastRow As Integer lastRow = sh.Cells(Rows.Count, 1).End(xlUp).Row With ComboBox1 For i = 2 To lastRow If ComboBox1 = "" Then .AddItem sh.Cells(i, 1).Value End If Next i End With End Sub ////////////////////////////////////////////////////// コンボボックスのリストの内容が消えてしまうので、 コードの内容は同じで以下のところにもコードを書いてみました。 ////////////////////////////////////////////////////// Private Sub Worksheet_Activate() Dim sh As Worksheet Set sh = Worksheets("マクロ") Dim i As Integer Dim lastRow As Integer lastRow = sh.Cells(Rows.Count, 1).End(xlUp).Row With ComboBox1 For i = 2 To lastRow If ComboBox1 = "" Then .AddItem sh.Cells(i, 1).Value End If Next i End With End Sub ////////////////////////////////////////////////////// なんだかもう、訳がわからずぐちゃぐちゃです。 コンボボックスの中に値が入っていると、実行ボタンをクリックしたときは正常にやりたい結果を出すことが実現できます。 ファイルを閉じた後に再度開いてもコンボボックスの中に値があるようにするにはどうしたらよいのか、ド素人の私にご教授いただきたくお願いいたします。

  • エクセルVBA　ブック間のコピー

    選択したテキストファイルをエクセルで開いたコピーし、 もう一つ開いたエクセルファイルにペーストするというマクロをVBAで 作成していますが、つまずいてしまいました。 ----------------------------------- Dim wb1 As String Dim wb2 As String Sub Opentxt() wb1 = Application.GetOpenFilename("テキストファイル,*.txt") If wb1 <> "False" Then Workbooks.OpenText Filename:=wb1, DataType:=xlDelimited, comma:=True End If End Sub Sub Copy() Dim LastRow As Long wb2 = Application.GetOpenFilename("Microsoft Excelブック,*.xls?") If wb2 <> "False" Then Workbooks.Open wb2 LastRow = wb2.Sheets("一覧表").Range("A" & Rows.Count). End(xlUp).Row wb2.Sheets("一覧表").Range("A5:A" & lastRow).Copy _ wb1.Sheets("Sheet1).Range("B33") End If End Sub ----------------------------------- Opentxtの方は問題ないですが、Copyの方を実行すると wb1とwb2で引っかかって「コンパイルエラー/ 修飾子が不正です」と 表示されて、エラーになってしまいます。 この場合変数の型などがおかしいのでしょうか？ excel2007を使用しています。 よろしくお願いします。

  • 既に開いているエクセルを閉じるには？

    既に該当のファイルが開いているのなら閉じたいのですが xlBook.Quitだとエラーになります。 Sub test1() Dim xlApp As Excel.Application Dim xlBook As Workbook Dim FileName As String FileName = "C:\test.xlsm" Set xlApp = GetObject("", "Excel.Application") 'GetObjectで合ってるか不安 Set xlBook = xlApp.Workbooks.Open(FileName) If xlBook.ReadOnly = True Then 'ファイルが開いてるのなら MsgBox "既にファイルが開いているので閉じます。" xlBook.Quit 'エラー　438 End If xlApp.Quit 'これって何のために必要？ Set xlBook = Nothing 'ココを通り過ぎるのにすごく時間がかかる。 Set xlApp = Nothing End Sub と言うコードを作りました。 xlBook.Quitがダメならどのコードを使えばいいでしょう？ また、 GetObject("", "Excel.Application") と言う開き方でいいのでしょうか？ あと、 xlApp.Quit は何のために必要なのでしょう？ タスクマネージーのプロセスを見ると、 Set xlApp = GetObject("", "Excel.Application") を通る時に新しいＥＸＣＥＬ．ＥＸＥが作成され、 Set xlApp = Nothing を通り過ぎる時に、そのＥＸＣＥＬ．ＥＸＥが消えます。 だから xlApp.Quit は不要ですか？

  • VBAで、定数式が必要ですのエラー対応

    指定のファイルをフォルダAからフォルダBへ移動させるというvbaを 見つけたのですが、 サンプルの表記は「"C:\Data\A"」と直接場所をしていしたものなので、 参照するフォルダ場所として、セルC1を参照させようと、 「Range("C1")」と書き直したところ、 「コンパイルエラー：定数式が必要です」とエラーになってしまいます。 どの様に書き直せばよいのでしょうか？ どなたかご存じでしたら、ぜひお教え下さい。 よろしくお願いします。 エクセル2010を使用しています。 Sub CheckAndMoveFiles() Const FolderA = Range("C1")　'エラー発生 'Const FolderA = "C:\Data\A"　サンプルの表記 　　Const FolderB = "C:\Data\B" Dim fso As Object Set fso = CreateObject("Scripting.FileSystemObject") Dim ws As Worksheet Set ws = ActiveSheet Dim lastRow As Long lastRow = ws.Range("A" & Rows.Count).End(xlUp).Row Dim r As Long Dim fileName As String For r = 1 To lastRow If ws.Cells(r, "A").Value <> "" Then ' fileName = ws.Cells(r, "A").Value & ".xls" fileName = ws.Cells(r, "A").Value If fso.FileExists(FolderA & "\" & fileName) = True Then fso.moveFile FolderA & "\" & fileName, FolderB & "\" & fileName End If End If Next End Sub

注目のQ&A

カテゴリ

専門家に質問してみよう

職業から探して質問する

あなたにピッタリな商品が見つかる！ OKWAVEセレクト

質問する