excel2007でネットワーク上のexcel2003 1M程度を開くとき異常に時間がかかる
kingsoft リアルタイムガードを停止したらいつもと同じくらいのスピードで開いた
2009年2月20日金曜日
excelからcsvを作る k3フォーマット
excelでcsvに保存すると ダブルコーテーションなしのテキストに書き出され、asの転送 basic順次で受け取れない。excel2007になってworksheet4.0形式で保存できなくなり、可変長で保存してasに転送で聞くなった。
以前にも同様のマクロを作ったがどうしても解析が面倒で使いにくい
余計なマクロの解析なしに、必要なパラメータを渡して asで受け取り可能なcsvを作成することを目的とする
意味
parm1 input excel book full path
parm2 input excel worksheet name
parm3 output csv k3format
parm4 文字属性の指定文字列 Attribute string of characters? google translate:-)
'使用例 とりあえず↓のsub3つをexcel vbaにコピぺして動きを追うと分かりやすいと思います
Sub make0()
Dim strsws As String
'as 転送記述fdfからフィールドの属性情報を書きだす
callfdf "(パス)\TMP421184.FDF", strsws
'家計簿.xlsのdataシートをkaikei.csvに書き出す
callfdf "(パス)\TMP421184.FDF", strsws
'fdfファイルが無い場合は自分で文字列を確認した渡す
'フィールドの属性は1=文字,2=数字で 12121111の8つのフィールド
MAKE_CSV_FILE "(パス)\test.xls", "as書き出し用", "(パス)\TMP421184.TXT" _
, strsws
End Sub
'--------------------------------------------------------------
Sub MAKE_CSV_FILE(inxls As String, sheetname As String, _
outfilecsv As String, strsws As String)
Dim frm(255)
Dim objHANI As Range
Dim startrow As Integer 'データ読込行 1なら2行目から
startrow = 1
bookname = ActiveWorkbook.Name
Workbooks(bookname).Activate '<---マクロ起動のエクセルが同じならコメントにする
Worksheets(sheetname).Activate
len01 = Len(strsws)
name1 = ActiveWorkbook.Name
'転送元範囲セット
endr = Cells(1, 1).End(xlDown).Row
Set objHANI = Range(Cells(2, 1), Cells(endr, len01)) 'excelの2行目からデータ
'Set objHANI = Range(rng)
'定義情報を配列に展開する
GoSub fdf
'ファイルをオープンする
Dim FNO As Integer 'ファイル番号
FNO = FreeFile '空いてるファイル番号を取出す
Open outfilecsv For Output As #FNO 'テキストファイルを新規作成
'行、列でループを作る
Dim y As Integer
Dim x As Integer
For y = startrow To objHANI.Rows.Count '行のループ
'1列目
If frm(1) = "1" Then
Print #FNO, Chr(&H22) & objHANI.Cells(y, 1).Value & Chr(&H22); '先頭項目の出力
Else
Print #FNO, objHANI.Cells(y, 1).Value; '先頭項目の出力
End If
'2列目以降
For x = 2 To objHANI.Columns.Count '列のループ
Print #FNO, ",";
If frm(x) = "1" Then '文字
Print #FNO, Chr(&H22) & objHANI.Cells(y, x).Value & Chr(&H22); '先頭項目の出力
Else '数字
Item1 = objHANI.Cells(y, x).Value
If Item1 = "" Then Item1 = "0"
Print #FNO, Item1; '先頭項目の出力
End If
Next x
Print #FNO, "" '改行のみ出力
Next y
'ファイルをクローズする
Close #FNO
Exit Sub
fdf:
For i = 1 To Len(strsws)
'ReDim frm(1)
frm(i) = Mid(strsws, i, 1)
Next
Return
End Sub
'--------------------------------------------------------------
Sub callfdf(in_file As String, strsws As String)
'fdffile asの転送記述ファイル,
Dim frm(255)
'in_file = "パス\hr01.fdf"
'** ファイルオープン
FNO = FreeFile
Open in_file For Input As FNO Len = 32000
x = 1
Do Until EOF(FNO)
Line Input #FNO, rec
'4行目から処理
If x >= 4 Then
len1 = Len(rec)
Count1 = 0
For i = 1 To Len(rec)
If Mid(rec, len1 - i, 1) = " " Then Count1 = Count1 + 1
'右から読み込んで2番目のスペースの左から1ケタ分読み込む
'PCFL MF 1 1 mf=フィールド名,文字数字種別,桁数 文字数字種別1=文字、2=数字
If Count1 = 2 Then
frm(x - 3) = Mid(rec, len1 - i + 1, 1)
Exit For
End If
Next
End If
x = x + 1
Loop
Dim y As Integer
'読みだした配列を文字列に書き出す
For y = 1 To 255
strsws = strsws & frm(y)
len2 = Len(strsws)
Next
Close FNO
End Sub
以前にも同様のマクロを作ったがどうしても解析が面倒で使いにくい
余計なマクロの解析なしに、必要なパラメータを渡して asで受け取り可能なcsvを作成することを目的とする
意味
parm1 input excel book full path
parm2 input excel worksheet name
parm3 output csv k3format
parm4 文字属性の指定文字列 Attribute string of characters? google translate:-)
'使用例 とりあえず↓のsub3つをexcel vbaにコピぺして動きを追うと分かりやすいと思います
Sub make0()
Dim strsws As String
'as 転送記述fdfからフィールドの属性情報を書きだす
callfdf "(パス)\TMP421184.FDF", strsws
'家計簿.xlsのdataシートをkaikei.csvに書き出す
callfdf "(パス)\TMP421184.FDF", strsws
'fdfファイルが無い場合は自分で文字列を確認した渡す
'フィールドの属性は1=文字,2=数字で 12121111の8つのフィールド
MAKE_CSV_FILE "(パス)\test.xls", "as書き出し用", "(パス)\TMP421184.TXT" _
, strsws
End Sub
'--------------------------------------------------------------
Sub MAKE_CSV_FILE(inxls As String, sheetname As String, _
outfilecsv As String, strsws As String)
Dim frm(255)
Dim objHANI As Range
Dim startrow As Integer 'データ読込行 1なら2行目から
startrow = 1
bookname = ActiveWorkbook.Name
Workbooks(bookname).Activate '<---マクロ起動のエクセルが同じならコメントにする
Worksheets(sheetname).Activate
len01 = Len(strsws)
name1 = ActiveWorkbook.Name
'転送元範囲セット
endr = Cells(1, 1).End(xlDown).Row
Set objHANI = Range(Cells(2, 1), Cells(endr, len01)) 'excelの2行目からデータ
'Set objHANI = Range(rng)
'定義情報を配列に展開する
GoSub fdf
'ファイルをオープンする
Dim FNO As Integer 'ファイル番号
FNO = FreeFile '空いてるファイル番号を取出す
Open outfilecsv For Output As #FNO 'テキストファイルを新規作成
'行、列でループを作る
Dim y As Integer
Dim x As Integer
For y = startrow To objHANI.Rows.Count '行のループ
'1列目
If frm(1) = "1" Then
Print #FNO, Chr(&H22) & objHANI.Cells(y, 1).Value & Chr(&H22); '先頭項目の出力
Else
Print #FNO, objHANI.Cells(y, 1).Value; '先頭項目の出力
End If
'2列目以降
For x = 2 To objHANI.Columns.Count '列のループ
Print #FNO, ",";
If frm(x) = "1" Then '文字
Print #FNO, Chr(&H22) & objHANI.Cells(y, x).Value & Chr(&H22); '先頭項目の出力
Else '数字
Item1 = objHANI.Cells(y, x).Value
If Item1 = "" Then Item1 = "0"
Print #FNO, Item1; '先頭項目の出力
End If
Next x
Print #FNO, "" '改行のみ出力
Next y
'ファイルをクローズする
Close #FNO
Exit Sub
fdf:
For i = 1 To Len(strsws)
'ReDim frm(1)
frm(i) = Mid(strsws, i, 1)
Next
Return
End Sub
'--------------------------------------------------------------
Sub callfdf(in_file As String, strsws As String)
'fdffile asの転送記述ファイル,
Dim frm(255)
'in_file = "パス\hr01.fdf"
'** ファイルオープン
FNO = FreeFile
Open in_file For Input As FNO Len = 32000
x = 1
Do Until EOF(FNO)
Line Input #FNO, rec
'4行目から処理
If x >= 4 Then
len1 = Len(rec)
Count1 = 0
For i = 1 To Len(rec)
If Mid(rec, len1 - i, 1) = " " Then Count1 = Count1 + 1
'右から読み込んで2番目のスペースの左から1ケタ分読み込む
'PCFL MF 1 1 mf=フィールド名,文字数字種別,桁数 文字数字種別1=文字、2=数字
If Count1 = 2 Then
frm(x - 3) = Mid(rec, len1 - i + 1, 1)
Exit For
End If
Next
End If
x = x + 1
Loop
Dim y As Integer
'読みだした配列を文字列に書き出す
For y = 1 To 255
strsws = strsws & frm(y)
len2 = Len(strsws)
Next
Close FNO
End Sub
登録:
投稿 (Atom)