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が開いて毎日の作業が自動で済むようにすることです。

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

回答の条件
  • 1人5回まで
  • 登録:2008/12/05 01:50:07
  • 終了:2008/12/07 19:49:42

ベストアンサー

id:Mook No.3

Mook回答回数1312ベストアンサー獲得回数3912008/12/06 13:56:04

ポイント100pt

すでに解決したのでいまさらですが、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

その他の回答(2件)

id:airplant No.1

airplant回答回数220ベストアンサー獲得回数492008/12/06 03:13:14

ポイント100pt

久しぶりに長いマクロを作ってみました(と言っても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になります

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

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

id:ikazuo

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分

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

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

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

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

2008/12/07 12:24:47
id:SALINGER No.2

SALINGER回答回数3454ベストアンサー獲得回数9692008/12/06 10:07:58

ポイント100pt

変数が多くてわかりずらいコードになってしまいましたが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
id:ikazuo

実行できました.

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

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

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

2008/12/06 12:39:12
id:Mook No.3

Mook回答回数1312ベストアンサー獲得回数3912008/12/06 13:56:04ここでベストアンサー

ポイント100pt

すでに解決したのでいまさらですが、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
  • id:airplant
    >BOOK1 hoge_,1130,.csvは不変。年月日は当日分が付与される。
    >      [0-9][0-9]は1130の後ろになんらかの数字が変動で入るという
    >意味で、01や00や03が入ります。
    → Book1の最後の2文字([0-9][0-9])は可変なのですね?
     そうするとファイルの特定ができないと思うのですが、、、
     同じ形式のファイルは1つしかありませんか?
     もしくは、複数あって実行時に人が選択する方式ですか?
  • id:SALINGER
    ダウンロードしたファイルを見てみると、1.csvと2.csvはcsvファイルではなくて、
    Excelファイルの拡張子を変えた物のようですが、
    実際のファイルもテキストでカンマ区切りのCSVファイルではないのでしょうか?
  • id:ikazuo
    SALINGERさん 2008-12-05 08:16:34
    > 実際のファイルもテキストでカンマ区切りのCSVファイルではないのでしょうか?
    実際のファイルはcsvファイルです。

    airplantさん 2008-12-05 03:07:57
    > 同じ形式のファイルは1つしかありませんか?
    > もしくは、複数あって実行時に人が選択する方式ですか?
    その日ごとにフォルダを作成し、その中に2つのcsvファイルをダウンロードしておいてからの
    作業になります。ですので、そのフォルダまで行けば同じ形式のファイルは1つしかないという
    ことになります。
    現在はオペレータが手動でファイル選択して作業していますが、自動化できないものかと考えて
    います。
  • id:airplant
    ikazuoさんへ
    マクロが動かなかったようですね。
    12/5 10:46のコメントから、日付と連動してファイル名を自動選択するものと思いましたので、日付を元に自動でファイル名を決めて持って来ています。
    確認される場合は、当日分にファイル名を変更するなりしてお願いします。
    それとも、使用者に選択させる必要があるということでしょうか?
  • id:Mook
    そのあたりのファイル運用の仕様を明確に提示されていると、
    それに沿った回答ができたかと思います。

    回答内で提示したサンプルは、指定フォルダから規定された形式
     hoge_yyyymmdd1130[0-9][0-9].csv
     lalala_yyyymmdd09_z.csv
    に正規表現でマッチするファイルを対象として、処理するように
    しています(yyyymmddは現在の日付に置換)。

    それよりもフォルダの選択を自動でできるようにした方が便利で
    あれば、その方が良かったかもしれません。
  • id:airplant
    ikazuoさんへ

    どうも、環境によっては探すフォルダが違ってしまいエラーになるので、エラーの箇所を次のように変更すれば動きます。すみませんでした。

    Workbooks.Open Filename:=sGetFileName
     ↓
    Workbooks.Open Filename:=ActiveWorkbook.Path & "\" & sGetFileName

    又、日付に連動させたくないときは、次のように変更すれば、自動で該当ディレクトリにある1つのファイルを持ってきます。
    '旧 sToday = Format(Date, "yyyymmdd")
    sToday = "*"  '新
  • id:ikazuo
    airplant さん

    エラー箇所の訂正で問題なく動きました。
    ありがとうございます。

    また、日付に連動させたくない場合の方法まで示していただきありがとうございます。
    実は、前日の日付のファイルを処理する場合もあるため、これはとてもありがたいです。
  • id:ikazuo
    Mookさん

    「指定したセルにファイル情報を置き、実行します。」
    というのは、「データフォルダのパス」のところに処理したいファイルが入っているフォルダのパスを貼り付け、
    「ファイルセット」ボタンを押下するということだろうと理解し、実行してみたのですが、どうもうまく動きま
    せんでした。おそらくわたしのやり方に何かまずいところがあるかと思いますので、実行方法を今一度ご説明
    いただけないでしょうか。

    お手数お掛けいたします。
  • id:Mook
    「うまく動きません。」とよく言われるのですが、どのようにうまくいかないかが
    わからないと、何度もやり取りをすることになります。

    指定したフォルダ下に今日の日付の
     hoge_yyyymmdd1130[0-9][0-9].csv
     lalala_yyyymmdd09_z.csv
    というファイルがあるのでしょうか。

    正規表現がわからないというのであれば、C6、C9 にファイル名そのものを書いてください。

    該当するファイルが見つかれば、下のボタンが押せる状態になるので、あとは押すだけです。

    それでもうまくいかない場合は、どこまで処理が進んでいて、どこでうまくいかないか。
    可能であればVBEでステップ実行し、どのステップでエラーが起きているかを報告ください。

    VBA を業務に使用したいのであれば、VBEのデバッグ方法等は覚えておいた方が良いかと思います。
    http://www.asahi-net.or.jp/~ef2o-inue/vba_k/sub04_200.html
  • id:ikazuo
    Mookさん

    失礼いたしました。
    指定したフォルダ下に今日の日付のファイルがある状態です。
    その上で「比較実行」ボタンを押し、当日日付名のシートができるわけですが、
    その結果、新しくできたシートのセルB1には文字化けした内容が表示され、C1にはFALSEと表示されます。
    その他のセルには何も入力されないです。
    マクロはきちんと動いているようですが、表示結果が求めているものとは違うようです。

    URL、ありがとうございます。
    活用させていただきます。

  • id:Mook
    ファイルの選択まではうまくいっている状況でしょうか。
    気になるのは、サンプルに上がっていたファイルがCSVではなくEXCELファイルだったのですが、
    その点は問題ありませんか?

    他の方の回答はBookとして一度開いているので、どちらでも動作するかもしれませんが、
    私のはテキストファイルとして開いているので、CSV でないと動作しません。

    一度メモ帳等で開いて問題ないことを確認できますか?
  • id:ikazuo
    Mookさん

    仰るとおり、ファイルがCSVではなくEXCELファイルだったことに問題があったようです。
    メモ帳でCSVファイルを作り直して実行したところうまく動作しました。
    ありがとうございます。
  • id:ikazuo
    SALINGERさん Mookさん

    もし、hogeファイルとlalalaファイルのB列に数字が移動していた場合、つまり、
     hogeファイルのB列に2569999などの数字、C列に0か1。
     lalalaファイルのB列に数字。  の場合。
    どの部分を変更することで処理可能となりますか?

    以下はSALINGERさんからいただいたコードの一部分をわたしが変更してみたものです。
    数字の部分だけを変更してうまくいくかどうか試してみました。
    動作結果は、バグではないのですが、データが貼り付けられる場所が違っていたり、
    並べ替えがうまくいかないなどの不具合がでます。

    'hogeシートをコピー
    With WB1.Worksheets(1)
    lastRow = .Cells(Rows.Count, 2).End(xlUp).Row
    j = 2
    For i = 1 To lastRow
    If .Cells(i, 3).Value = "0" Then
    ws.Cells(j, 2).Value = .Cells(i, 2).Value
    j = j + 1
    End If
    Next i
    End With

    'lalalaシートをコピー
    With WB2.Worksheets(1)
    lastRow = .Cells(Rows.Count, 2).End(xlUp).Row
    j = 2
    For i = 1 To lastRow
    If .Cells(i, 2).Value <> "" Then
    ws.Cells(j, 3).Value = .Cells(i, 2).Value
    j = j + 1
    End If
    Next i

    ご回答いただけると幸いです。
    必要であれば再度質問として登録させていただきます。
    よろしくお願い致します。

  • id:SALINGER
    それだと、B列とC列に貼り付けているのでソートする列も変わってるくるので
    貼り付けるのがA列とB列のままだとすると
    >>
    'hogeシートをコピー
    With WB1.Worksheets(1)
    lastRow = .Cells(Rows.Count, 2).End(xlUp).Row
    j = 1
    For i = 1 To lastRow
    If .Cells(i, 3).Value = "0" Then
    ws.Cells(j, 1).Value = .Cells(i, 2).Value
    j = j + 1
    End If
    Next i
    End With

    'lalalaシートをコピー
    With WB2.Worksheets(1)
    lastRow = .Cells(Rows.Count, 2).End(xlUp).Row
    j = 1
    For i = 1 To lastRow
    If .Cells(i, 2).Value <> "" Then
    ws.Cells(j, 2).Value = .Cells(i, 2).Value
    j = j + 1
    End If
    Next i
    End With
    <<
  • id:ikazuo
    SALINGERさん

    できました。
    ありがとうございました。
  • id:Mook
    ご自身で解決されたかもしれませんが、私の場合は下記のようなコードになります。

      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) >= 2 Then
                ^^^
          If cc(2) = 0 Then
            ^^^^
            dstWS.Cells(i, "A").value = cc(1)
                           ^^^
            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) >= 1 Then
                ^^^
          dstWS.Cells(i, "B").value = cc(1)
                         ^^^
        End If
        i = i + 1
      Next
  • id:ikazuo
    Mookさん

    非常にわかりやすくご回答いただき助かります。
    上のように訂正したところ期待通りの動作をしました。
    ありがとうございました。
  • id:ikazuo
    本当に最後にします。ご回答いただけましたら幸いです。
    以下の場合はどのようになりますでしょうか。
     hogeファイルのB列に2569999などの数字、飛んでD列に0か1。C列は無視。
    lalalaファイルはA列に2569999などの数字。
    の場合、どの部分を変更することで処理可能となりますか?
  • id:airplant
    お呼びではないですが、、、笑

    「ikazuoさん 2008-12-08 23:38:07」仕様

    #1プログラムのSub getCells(・・・近辺に次の4行を追加すれば、ご要望の動作になります(インタフェースは若干綺麗ではないですが)。

    Sub getCells(oWs As Workbook, sHead As String, bFlg As Boolean)

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

      oWs.Activate
    ' ===追加開始
      If bFlg Then
        Columns("C:C").Delete shift:=xlToLeft
        Columns("A:A").Delete shift:=xlToLeft
      End If
    ' ===追加終了
      '先頭からデータ開始しているときはヘッダ用に1行入れる

    P.S. 以前の修正も忘れずにお願いします(フォルダ指定、日付連動止め)
  • id:Mook
    変数 cc が1行だと思ってください。
     cc(0)・・・A列
     cc(1)・・・B列
     cc(2)・・・C列
    のようなイメージです。

    UBound(cc) はデータが何列まであるかを表します。
    3列目のデータ(cc(2))を取りたい場合、これ(UBound(cc))が 2 以上でないとエラーに
    なるので条件判定をしています。

        If UBound(cc) >= 2 Then
          If cc(2) = 0 Then
            dstWS.Cells(i, "A").value = cc(1)
          End If
        End If

    は1行のデータが3列以上あって、3列目(cc(2))が0のときに2列目(cc(1))をセルに記入するという
    処理を表します。

    これに沿って、何列目のデータで条件判定し、何列目のデータを取得したいかを目的に合わせて、カスタマイズ
    してください。
  • id:ikazuo
    airplantさん Mookさん

    できました。
    コードの理解を進めていきます。
    また自分で解けない問題があれば質問させてください。
    ありがとうございました。

この質問への反応(ブックマークコメント)

「あの人に答えてほしい」「この質問はあの人が答えられそう」というときに、回答リクエストを送ってみてましょう。

これ以上回答リクエストを送信することはできません。制限について

絞り込み :
はてなココの「ともだち」を表示します。
回答リクエストを送信したユーザーはいません