質問です。

\test\の中に複数のCSVファイルがあります。
B列に数値1のデータがあります。数値1以外のA列データを削除して
最後にB列の数値1のB列も削除するマクロをお願いします
データはA1からあります

A列 B列
aaaaa 1
bbbbb 1
ccccc
ccccc
ddddd 1
eeeee
eeeee
eeeee


答え
A列
aaaaa
bbbbb
ddddd

回答の条件
  • 1人3回まで
  • 13歳以上
  • 登録:2011/11/29 19:51:36
  • 終了:2011/11/30 15:05:11

ベストアンサー

id:taknt No.3

きゃづみぃ回答回数13537ベストアンサー獲得回数11982011/11/30 10:36:12

ポイント100pt

ソートするように修正しました。

Sub main()
Dim p As String
'対象フォルダを指定してください。
'このフォルダに この実行用のブックは 入れないでください。
p = "C:\test\"

'処理対象となる拡張子を指定して 呼び出します。
Call jikkou(p, "csv")

End Sub


Sub jikkou(p As String, s As String)

Dim bk As Workbook
Dim gg As Long
Application.DisplayAlerts = False

    
f = Dir(p & "*." & s, vbNormal)

Do While f <> ""
    Set w = Workbooks.Open(Filename:=p & f, UpdateLinks:=False, ReadOnly:=False)
    '処理対象は 1番目のシートのみ。
    
    With w.Sheets(1)
        .Cells.Select
        Selection.Sort Key1:=.Range("B1"), Order1:=xlDescending, Header:=xlGuess, _
            OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, SortMethod _
            :=xlPinYin, DataOption1:=xlSortNormal
        
        If .Range("A2") = "" Then
            fa = 1
        Else
            fa = .Range("A1").End(xlDown).Row
        End If
        
        If .Range("B2") = "" Then
            fb = 1
        Else
            fb = .Range("B1").End(xlDown).Row + 1
        End If
            .Rows(fb & ":" & fa).Delete Shift:=xlUp
            .Columns("B:B").ClearContents

     End With
         
    w.Save
    w.Close
    f = Dir
Loop

Application.DisplayAlerts = True

End Sub

id:inosisi4141

ありがとうございます
こちらの説明不足でお手間とらせて申し訳ございませんでした
今度は完璧です速度も申し分ありません。
本当にありがとうございました。

2011/11/30 15:04:25

その他の回答(2件)

id:windofjuly No.1

うぃんど回答回数2625ベストアンサー獲得回数11492011/11/29 20:16:02

ポイント10pt

上書き保存しますので注意してください

Sub Macro1()
    Const path = "\test"
    Const grab = "*.csv"
    Const keyCol = "B" ' B列
    Const group1 = 1 ' 残す対象の値
    
    Dim file As String
    Dim last As Long
    Dim i As Long

    file = Dir(path & "\" & grab, vbNormal)
    Do While file <> ""
        With Workbooks.Open(path & "\" & file)
            last = Sheets(1).Cells(Rows.Count, keyCol).End(xlUp).Row
            For i = last To 1 Step -1
                If Range(keyCol & i).Value <> group1 Then Range(i & ":" & i).Delete Shift:=xlUp
            Next i
            Columns(keyCol & ":" & keyCol).Delete Shift:=xlToLeft
            .Close SaveChanges:=True
        End With
        file = Dir
    Loop
End Sub
id:inosisi4141

ありがとうございます。
このマクロを実行しますとB列の1の数字のみ削除されているみたいですが

B列の1に該当するA列のデータのみ残し他を削除したいのですが
現在の手順はB列をソートして1が無いA列のデータを削除し最後にB列の1を削除しています結果B列の1に該当するA列のデータのみが残ります
よろしくお願いします。

2011/11/30 10:06:05
id:taknt No.2

きゃづみぃ回答回数13537ベストアンサー獲得回数11982011/11/29 20:16:44

Sub main()
Dim p As String
'対象フォルダを指定してください。
'このフォルダに この実行用のブックは 入れないでください。
p = "C:\test\"

'処理対象となる拡張子を指定して 呼び出します。
Call jikkou(p, "csv")

End Sub


Sub jikkou(p As String, s As String)

Dim bk As Workbook
Dim gg As Long
Application.DisplayAlerts = False

    
f = Dir(p & "*." & s, vbNormal)

Do While f <> ""
    Set w = Workbooks.Open(Filename:=p & f, UpdateLinks:=False, ReadOnly:=False)
    '処理対象は 1番目のシートのみ。
    
    With w.Sheets(1)
        
        If .Range("A2") = "" Then
            ff = 1
        Else
            ff = .Range("A1").End(xlDown).Row
        End If
        
        For gg = ff To 1 Step -1
        
            If .Cells(gg, "B") = 1 Then
                .Cells(gg, "B") = ""
            Else
                .Rows(gg).Delete Shift:=xlUp
            End If
        
        Next gg
    End With
         
    w.Save
    w.Close
    f = Dir
Loop

Application.DisplayAlerts = True

End Sub

id:inosisi4141

ありがとうございます
ちょっと時間がかかりすぎる感じです
現在の手順はB列をソートして1が無いA列のデータを削除し最後にB列の1を削除しています結果B列の1に該当するA列のデータのみが残ります
現在より早く削除する方法がありましたらお願いします
よろしくお願いします。

2011/11/30 10:08:21
id:taknt

その手順のほうが 速いですね。

とりあえず 質問の内容を満たすプログラムを作成しただけで、速度に関しては 特に考慮していません。

2011/11/30 10:27:08
id:taknt No.3

きゃづみぃ回答回数13537ベストアンサー獲得回数11982011/11/30 10:36:12ここでベストアンサー

ポイント100pt

ソートするように修正しました。

Sub main()
Dim p As String
'対象フォルダを指定してください。
'このフォルダに この実行用のブックは 入れないでください。
p = "C:\test\"

'処理対象となる拡張子を指定して 呼び出します。
Call jikkou(p, "csv")

End Sub


Sub jikkou(p As String, s As String)

Dim bk As Workbook
Dim gg As Long
Application.DisplayAlerts = False

    
f = Dir(p & "*." & s, vbNormal)

Do While f <> ""
    Set w = Workbooks.Open(Filename:=p & f, UpdateLinks:=False, ReadOnly:=False)
    '処理対象は 1番目のシートのみ。
    
    With w.Sheets(1)
        .Cells.Select
        Selection.Sort Key1:=.Range("B1"), Order1:=xlDescending, Header:=xlGuess, _
            OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, SortMethod _
            :=xlPinYin, DataOption1:=xlSortNormal
        
        If .Range("A2") = "" Then
            fa = 1
        Else
            fa = .Range("A1").End(xlDown).Row
        End If
        
        If .Range("B2") = "" Then
            fb = 1
        Else
            fb = .Range("B1").End(xlDown).Row + 1
        End If
            .Rows(fb & ":" & fa).Delete Shift:=xlUp
            .Columns("B:B").ClearContents

     End With
         
    w.Save
    w.Close
    f = Dir
Loop

Application.DisplayAlerts = True

End Sub

id:inosisi4141

ありがとうございます
こちらの説明不足でお手間とらせて申し訳ございませんでした
今度は完璧です速度も申し分ありません。
本当にありがとうございました。

2011/11/30 15:04:25

コメントはまだありません

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

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

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

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