人力検索はてな
モバイル版を表示しています。PC版はこちら
i-mobile

EXCELでのデータ処理についての質問です。
2つのブックのA列同士が同等であるか否かをチェックするマクロを作成したいと考えています。

2つのファイルは毎日決まった時間に処理しています。
そのため、ファイル名には一定の法則があります。

BOOK1 hoge_yyyymmdd1130[0-9][0-9].csv
BOOK2 lalala_yyyymmdd09_z.csv

BOOK1 hoge_,1130,.csvは不変。年月日は当日分が付与される。
[0-9][0-9]は1130の後ろになんらかの数字が変動で入るという意味で、01や00や03が入ります。
BOOK2 lalala_,09_z.csvは不変。年月日のみ当日に変動。

ファイルをみてください。
作業順(1.bmp→2.bmp→3.bmp)です。
http://www.filebank.co.jp/wblink/87712ac6d8835942fff485c97c17e4d8

いつもの作業では、上の2つのBOOKを開き、さらに新規BOOK(BOOK3とします)を開き、横に並べ、
BOOK3に上のBOOK1,2の各A列をコピーして比較しています。

希望は、新規ファイルのBOOK3にマクロを置き、このファイルを開いてマクロツールを
実行することで他2つのBOOKが開いて毎日の作業が自動で済むようにすることです。

よろしくお願いいたします。

●質問者: ikazuo
●カテゴリ:コンピュータ インターネット
✍キーワード:00 BMP book CSV Excel
○ 状態 :終了
└ 回答数 : 3/3件

▽最新の回答へ

1 ● airplant
●100ポイント

久しぶりに長いマクロを作ってみました(と言っても100行しかない・・・笑)。

ダウンロードしたファイルで動作は確認済みです。

Option Explicit

Const sInFile1_p1 As String = "hoge_"
Const sInFile1_p2 As String = "1130??.csv"
Const sInFile2_p1 As String = "lalala_"
Const sInFile2_p2 As String = "09_z.csv"


Sub a()
 Dim sToday As String
 Dim sCurPath As String
 
 Dim oWs0 As Workbook  ' 自身
 Dim oWs1 As Workbook  ' 入力1
 Dim oWs2 As Workbook  ' 入力2
 
  '入力ファイルのオープン
 Set oWs0 = ActiveWorkbook
 sToday = Format(Date, "yyyymmdd")
 
  '起動場所をファイル格納場所とみなす
 sCurPath = ActiveWorkbook.Path
 
 Set oWs1 = OpenBook(sCurPath & "\" & sInFile1_p1 & _
 sToday & sInFile1_p2)
 If IsNull(oWs1) Then Exit Sub
 
 Set oWs2 = OpenBook(sCurPath & "\" & sInFile2_p1 & _
 sToday & sInFile2_p2)
 If IsNull(oWs2) Then Exit Sub
 
  ' 1つ目のデータを貼り付け
 Call getCells(oWs1, sInFile1_p1, True)
 ActiveSheet.Paste oWs0.Sheets(1).Range("A1")
 
  ' 2つ目のデータを貼り付け
 Call getCells(oWs2, sInFile2_p1, False)
 ActiveSheet.Paste oWs0.Sheets(1).Range("B1")
 
  ' 比較式を入れる
 oWs0.Activate
 Range("C2", "C" & Range("A1").CurrentRegion.Rows.Count).Formula = "=A2=B2"
 Range("A1").Select
 
  '入力ファイルをクローズする(確認時はコメントにするといい)
 Application.DisplayAlerts = False
 oWs2.Close
 oWs1.Close
 Application.DisplayAlerts = True
 
End Sub

' 曖昧な名前の入力ファイルを開く
'ret=ファイル有:ハンドル、無:Null

Function OpenBook(sFileName As String) As Workbook
 
 Dim sGetFileName As String
 sGetFileName = Dir(sFileName)
 If sGetFileName = "" Then
 MsgBox "入力ファイルがありません:" & sFileName
 Set OpenBook = Null
 Exit Function
 End If
 Workbooks.Open Filename:=sGetFileName
 Set OpenBook = ActiveWorkbook

End Function

'任意の位置から開始している行範囲をコピーする
'sHead:項目名、bFlg:フィルタ有無
Sub getCells(oWs As Workbook, sHead As String, bFlg As Boolean)

 Dim oLeftTop As Range  ' Sort用左上セル格納

 oWs.Activate
  '先頭からデータ開始しているときはヘッダ用に1行入れる
 If Range("A1").Value <> "" Then
 Rows("1:1").Insert Shift:=xlDown
 Range("A1").Select
 Else
 Range("A1").End(xlDown).Offset(-1, 0).Select
 End If
 Set oLeftTop = ActiveCell
 oLeftTop.Value = sHead

 With Selection
 .CurrentRegion.Select
 .Sort Key1:=oLeftTop, Order1:=xlDescending, Header:=xlGuess, _
 OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
 SortMethod:=xlPinYin, DataOption1:=xlSortNormal
  'bug? (1回だと正しくソートされず)
 .Sort Key1:=oLeftTop, Order1:=xlDescending, Header:=xlGuess, _
 OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
 SortMethod:=xlPinYin, DataOption1:=xlSortNormal
 
 If bFlg Then
 .AutoFilter
 .AutoFilter Field:=2, Criteria1:="0"
 End If
 .CurrentRegion.Copy
 End With
End Sub

注意:

●マクロを該当のフォルダに入れる前提です。

→ 本当は上位フォルダにマクロをおいて、毎日のファイルはyyyymmddのフォルダに入れるのが楽と思います。

●結果は、画面上に出ますが、保存はしていません。

●元々の要求仕様上、1件でも違っていると、その後は、全部Falseになります

→本当はマッチしているのとそうではないのが出したいのだと思うのですが、、、

まあ、通常は全件マッチしているので、そこまでは不要なのですね。

◎質問者からの返答

On 2008-12-06 23時47分

「Workbooks.Open Filename:=sGetFileName」という行に問題があると表示されます。

' 曖昧な名前の入力ファイルを開く
'ret=ファイル有:ハンドル、無:Null

Function OpenBook(sFileName As String) As Workbook
 
 Dim sGetFileName As String
 sGetFileName = Dir(sFileName)
 If sGetFileName = "" Then
 MsgBox "入力ファイルがありません:" & sFileName
 Set OpenBook = Null
 Exit Function
 End If
 ⇒ Workbooks.Open Filename:=sGetFileName
 Set OpenBook = ActiveWorkbook

エラー表示は以下のものが出ました。

実行時エラー '1004':
'hoge_20081206113022.csv'が見つかりません。ファイル名およびファイルの
保存場所が正しいかどうか確認してください。

On 2008-12-07 12時22分

当該箇所を訂正したところ動きました。

表示もとてもわかりやすくて素晴らしいです。

何から何まで教えていただきすみません。

ありがとうございました!


2 ● SALINGER
●100ポイント

変数が多くてわかりずらいコードになってしまいましたがVBAで作ってみました。

CSVファイルならばExcelで開かずに読み込んで処理するという方法もありましたが、作業手順どおりにExcelで開いて処理するように作ってみました。

使い方は、ファイルを開くダイアログが出るので、Book1かBook2のどちらかを選べば同じ日付のもう一つも開いて処理するようにしています。

Sub Macro()
 Dim dirPass As String
 Dim str As String
 Dim shizuke As String
 Dim pass1 As String
 Dim pass2 As String
 Dim WB1 As Workbook
 Dim WB2 As Workbook
 Dim lastRow As Long
 Dim i As Long
 Dim j As Long
 Dim ws As Worksheet
 Dim OpenFileName As String
 
  '開くブックの取得
 OpenFileName = Application.GetOpenFilename()
 If OpenFileName = "False" Then Exit Sub
 
 If InStr(1, OpenFileName, "_") <= 0 Then Exit Sub
 shizuke = Mid(OpenFileName, InStrRev(OpenFileName, "_", Len(OpenFileName) - 7) + 1, 8)
 dirPass = Mid(OpenFileName, 1, InStrRev(OpenFileName, "\") - 1)
 
  'ファイルが存在するか調べる
 pass1 = Dir(dirPass & "\hoge_" & shizuke & "1130*.csv")
 pass2 = Dir(dirPass & "\lalala_" & shizuke & "09_z.csv")
 If pass1 = "" Or pass2 = "" Then
 MsgBox "日付のファイルが存在しません"
 End If
 
 Set ws = ActiveSheet
 
  'ブックを開く
 On Error Resume Next
 Set WB1 = Workbooks.Open(dirPass & "\" & pass1)
 Set WB2 = Workbooks.Open(dirPass & "\" & pass2)
 On Error GoTo 0
 
  'hogeシートをコピー
 With WB1.Worksheets(1)
 lastRow = .Cells(Rows.Count, 1).End(xlUp).Row
 j = 1
 For i = 1 To lastRow
 If .Cells(i, 2).Value = "0" Then
 ws.Cells(j, 1).Value = .Cells(i, 1).Value
 j = j + 1
 End If
 Next i
 End With
 
  'lalalaシートをコピー
 With WB2.Worksheets(1)
 lastRow = .Cells(Rows.Count, 1).End(xlUp).Row
 j = 1
 For i = 1 To lastRow
 If .Cells(i, 1).Value <> "" Then
 ws.Cells(j, 2).Value = .Cells(i, 1).Value
 j = j + 1
 End If
 Next i
 End With
 
  '降順で並べ替え
 ws.Columns("A:A").Sort Key1:=ws.Range("A1"), Order1:=xlDescending, Header:=xlGuess, _
 OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, SortMethod _
 :=xlPinYin, DataOption1:=xlSortNormal
 ws.Columns("B:B").Sort Key1:=ws.Range("B1"), Order1:=xlDescending, Header:=xlGuess, _
 OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, SortMethod _
 :=xlPinYin, DataOption1:=xlSortNormal
 
  '判定
 lastRow = ws.Cells(Rows.Count, 1).End(xlUp).Row
 For i = 1 To lastRow
 If ws.Cells(i, 1).Value = ws.Cells(i, 2).Value Then
 ws.Cells(i, 3).Value = "TRUE"
 Else
 ws.Cells(i, 3).Value = "FALSE"
 End If
 Next i
End Sub
◎質問者からの返答

実行できました.

VBAは作業を自動化して正確性と速度を高めるために今のわたしに必要な技術です.

いただいたコードを自分なりに分析して、今度は自力で解決できるようにしていきたいと考えています.

ありがとうございました<(_ _*)>


3 ● Mook
●100ポイント ベストアンサー

すでに解決したのでいまさらですが、csvファイルを直接読み込んで実行する例です。

指定したセルにファイル情報を置き、実行します。


下記にファイル読込みの機能を追加した実装サンプルを置きましたので、ご参考ください。

http://www.filebank.co.jp/wblink/11e0bf40fa6c19d56986118813bec85...


Public Const MAIN_SHEET = "MAIN"
Public Const FILE_PATH = "C3"
Public Const FILE_A_FORM = "C6"
Public Const FILE_B_FORM = "C9"
Public Const FILE_A = "C7"
Public Const FILE_B = "C10"

Sub compCSVs()
 If Mid(Range(FILE_PATH), Len(Range(FILE_PATH)), 1) = "\" Then
 Application.EnableEvents = False
 Range(FILE_PATH) = Left(Range(FILE_PATH), Len(Range(FILE_PATH)) - 1)
 Application.EnableEvents = True
 End If

 Dim srcWS As Worksheet
 Set srcWS = Worksheets(MAIN_SHEET)

 Dim dstWS As Worksheet
 On Error Resume Next
 Set dstWS = Worksheets(Format(Date, "yyyymmdd"))
 On Error GoTo 0
 
 If dstWS Is Nothing Then
 Set dstWS = Worksheets.Add(after:=Worksheets(Worksheets.Count))
 Else
 If MsgBox(dstWS.Name & "は既に存在します。上書きしますか?", vbYesNo) = vbYes Then
 dstWS.Columns("A:C").value = ""
 Else
 Exit Sub
 End If
 End If
 
 dstWS.Name = Format(Date, "yyyymmdd")
 Dim fso As Object, ff, ll, cc, i As Long
 Set fso = CreateObject("Scripting.FileSystemObject")

 i = 1
 ff = fso.OpenTextFile(srcWS.Range(FILE_PATH) & "\" & srcWS.Range(FILE_A)).readAll()
 For Each ll In Split(ff, vbNewLine)
 cc = Split(ll, ",")
 If UBound(cc) >= 1 Then
 If cc(1) = 0 Then
 dstWS.Cells(i, "A").value = cc(0)
 i = i + 1
 End If
 End If
 Next

 i = 1
 ff = fso.OpenTextFile(srcWS.Range(FILE_PATH) & "\" & srcWS.Range(FILE_B)).readAll()
 For Each ll In Split(ff, vbNewLine)
 cc = Split(ll, ",")
 If UBound(cc) >= 0 Then
 dstWS.Cells(i, "B").value = cc(0)
 End If
 i = i + 1
 Next

 dstWS.Columns("A").Sort Key1:=dstWS.Range("A1"), Order1:=xlDescending, Header:=xlNo
 dstWS.Columns("B").Sort Key1:=dstWS.Range("B1"), Order1:=xlDescending, Header:=xlNo
 
 Dim lr As Long
 lr = dstWS.Range("A" & Rows.Count).End(xlUp).Row
 If lr < dstWS.Range("B" & Rows.Count).End(xlUp).Row Then
 lr = dstWS.Range("B" & Rows.Count).End(xlUp).Row
 End If
 dstWS.Range("C1").Resize(lr, 1).FormulaR1C1 = "=IF(RC[-2]=RC[-1],TRUE,FALSE)"
 dstWS.Activate
End Sub
関連質問


●質問をもっと探す●



0.人力検索はてなトップ
8.このページを友達に紹介
9.このページの先頭へ
対応機種一覧
お問い合わせ
ヘルプ/お知らせ
ログイン
無料ユーザー登録
はてなトップ