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

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

A列B列
aaaaa1
bbbbb1
ccccc
ccccc
ddddd1
eeeee
eeeee
eeeee


答え
A列
aaaaa
bbbbb
ddddd


●質問者: inosisi
●カテゴリ:コンピュータ インターネット
○ 状態 :終了
└ 回答数 : 3/3件

▽最新の回答へ

1 ● うぃんど
●10ポイント

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

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

inosisiさんのコメント
ありがとうございます。 このマクロを実行しますとB列の1の数字のみ削除されているみたいですが B列の1に該当するA列のデータのみ残し他を削除したいのですが 現在の手順はB列をソートして1が無いA列のデータを削除し最後にB列の1を削除しています結果B列の1に該当するA列のデータのみが残ります よろしくお願いします。

2 ● きゃづみぃ
●0ポイント
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


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

きゃづみぃさんのコメント
その手順のほうが 速いですね。 とりあえず 質問の内容を満たすプログラムを作成しただけで、速度に関しては 特に考慮していません。

3 ● きゃづみぃ
●100ポイント ベストアンサー

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

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


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

●質問をもっと探す●



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