c:\test\の中にＴＡＢ切りのTXTファイルが複数あります
データはA列からs列まで
1行目は項目です
2行目からデータです
B列 09011112222
G列 09011112222
B列とG列は頭に0が付いた文字が含まれます
この0が取れないように
追加で空白のF列ができるマクロを作りたいのですが
結果F列が追加されA列からT列までとなります
よろしくお願いします
複数のtxtファイルは連続して実行できるようなマクロをお願いします
No.2
13539
1198
45pt
Sub main() Dim p As String '対象フォルダを指定してください。 'このフォルダに この実行用のブックは 入れないでください。 p = "C:\test\" '処理対象となる拡張子を指定して 呼び出します。 Call jikkou(p, "txt") End Sub Sub jikkou(p As String, s As String) Dim bk() As String Application.DisplayAlerts = False f = Dir(p & "*." & s, vbNormal) Do While f <> "" k = 0 ReDim bk(k) ch1 = FreeFile Open p & f For Input As #ch1 Do While Not EOF(ch1) 'ファイルの終端かどうかを確認します Line Input #ch1, textline 'データ行を読み込みます ReDim Preserve bk(k) bk(k) = textline k = k + 1 Loop Close #ch1 ch2 = FreeFile Open p & f For Output As #ch2 For i = 0 To k - 1 textline = bk(i) tabポイント = 1 For dd = 1 To 5 tabポイント = InStr(tabポイント, textline, vbTab) + 1 Next dd Debug.Print textline g = Left(textline, tabポイント - 1) & vbTab textline = g & Right(textline, Len(textline) - tabポイント + 1) Debug.Print textline Print #ch2, textline 'データの書き込みをします Next i Close #ch2 f = Dir Loop Application.DisplayAlerts = True End Sub
項目数が足りない場合は、補いません。
あくまでも F列以上ある項目に対してF列を挿入するのみです。
No.2
135391198
ここでベストアンサー
45pt
Sub main() Dim p As String '対象フォルダを指定してください。 'このフォルダに この実行用のブックは 入れないでください。 p = "C:\test\" '処理対象となる拡張子を指定して 呼び出します。 Call jikkou(p, "txt") End Sub Sub jikkou(p As String, s As String) Dim bk() As String Application.DisplayAlerts = False f = Dir(p & "*." & s, vbNormal) Do While f <> "" k = 0 ReDim bk(k) ch1 = FreeFile Open p & f For Input As #ch1 Do While Not EOF(ch1) 'ファイルの終端かどうかを確認します Line Input #ch1, textline 'データ行を読み込みます ReDim Preserve bk(k) bk(k) = textline k = k + 1 Loop Close #ch1 ch2 = FreeFile Open p & f For Output As #ch2 For i = 0 To k - 1 textline = bk(i) tabポイント = 1 For dd = 1 To 5 tabポイント = InStr(tabポイント, textline, vbTab) + 1 Next dd Debug.Print textline g = Left(textline, tabポイント - 1) & vbTab textline = g & Right(textline, Len(textline) - tabポイント + 1) Debug.Print textline Print #ch2, textline 'データの書き込みをします Next i Close #ch2 f = Dir Loop Application.DisplayAlerts = True End Sub
項目数が足りない場合は、補いません。
あくまでも F列以上ある項目に対してF列を挿入するのみです。
ありがとうございました
うまくいきました
処理速度は 遅かったですか?
No.3
18071
55pt
これでいかがでしょうか。
146
144
Option Explicit
Sub inosisi4141()
Const Folder As String = "C:\test\"
Dim FileName As String
' 高速化が必要なら続く2行のアポストロフィを削除して下さい
' Application.ScreenUpdating = False
' Application.Calculation = xlCalculationAutomatic
FileName = Dir(Folder)
Do While FileName <> ""
Workbooks.OpenText FileName:=Folder & FileName, _
DataType:=xlDelimited, ConsecutiveDelimiter:=False, _
Tab:=True, FieldInfo:=Array(Array(1, 2), Array(2, 2), _
Array(3, 2), Array(4, 2), Array(5, 2), Array(6, 2), _
Array(7, 2), Array(8, 2), Array(9, 2), Array(10, 2), _
Array(11, 2), Array(12, 2), Array(13, 2), Array(14, 2), _
Array(15, 2), Array(16, 2), Array(17, 2), Array(18, 2), _
Array(19, 2))
' FieldInfo の Array(X, Y) の意味
' X: 列番号 (A列 = 1, B列 = 2, ... , S列 = 19)
' Y: データ形式(XlColumnDataTypeクラス)
' 標準形式 = 1 (= xlGeneralFormat)
' 文字列形式 = 2 (= xlTextFormat)
' ※その他 略
Columns("F:F").Insert Shift:=xlToRight
Application.DisplayAlerts = False
ActiveWorkbook.SaveAs FileName:=Folder & FileName, _
FileFormat:=xlText, CreateBackup:=False
ActiveWorkbook.Close SaveChanges:=False
Application.DisplayAlerts = True
FileName = Dir()
Loop
' 高速化が必要なら続く2行のアポストロフィを削除して下さい
' Application.ScreenUpdating = True
' Application.Calculation = xlCalculationManual
End Sub
済みません…orz。
' Application.Calculation = xlCalculationAutomatic
の行と
' Application.Calculation = xlCalculationManual
の行が逆でした…。
ありがとうございました
うまくいきました
高速化の処理もありがとうございました
Silvanus
2012/10/09 18:50:30
inosisi
1
1
1
ありがとうございました
2012/10/10 11:59:45うまくいきました
処理速度は 遅かったですか?
2012/10/10 20:27:22