| |
▼kanabun さん：
>▼お困りです さん：
>
>こんにちは。
>
>>”ワークシートＡ”のＡ〜Ｈまでの範囲でかつ
>>データが存在する所までの部分をCSV形式にて出力したいと
>>考えています。
>>どの様な構文を作成すればよいでしょうか？
>
>新規Bookを挿入して（できれば Sheet枚数は１枚がよい）、
>元データシートの指定範囲をCopy して、新規BookのSheet1 に
>Pasteして、
>ファイルメニュー「名前をつけて保存」から、CSV形式で保存する
>といった手順でどうですかね？
>
>>”ワークシートＡ”のＡ〜Ｈまでの範囲でかつ
>>データが存在する所までの部分
>は、
>Worksheets("ワークシートＡ").UsedRange.Resize( ,8).Copy _
> 新しいBook.Sheets(1).Range("A1")
>
>といった感じで。
早々のご指導ありがとうございます。このサイトを見ていたら以前同様な質問で参考のURLが出ていたので調べました。
構文は以下です。ただ、ﾕｰｻﾞｰﾌｫｰﾑ上ではこのままでは動かないと思いまして追加で質問させていただきます。
Private Sub CommandButton1_Click()
ここにしたの構文を入れると思いますが
End Sub
下の構文の何処を修正したらよいでしょうか？よろしくご指導お願いします。
Option Explicit
' CSV形式テキストファイル書き出すサンプル
Sub WRITE_CSVFile()
Const cnsTITLE = "CSVテキストファイル出力処理"
Const cnsFILTER = "CSVファイル (*.csv;*.dat),*.csv;*.dat"
Dim xlAPP As Application ' Applicationオブジェクト
Dim intFF As Integer ' FreeFile値
Dim strFILENAME As String ' OPENするファイル名(フルパス)
Dim X(1 To 8) As Variant ' 書き出すレコード内容
Dim GYO As Long ' 収容するセルの行
Dim GYOMAX As Long ' データが収容された最終行
Dim lngREC As Long ' レコード件数カウンタ
Dim COL As Long ' カラム(Work)
' Applicationオブジェクト取得
Set xlAPP = Application
' 「名前を付けて保存」のフォームでファイル名の指定を受ける
xlAPP.StatusBar = "出力するファイル名を指定して下さい。"
strFILENAME = xlAPP.GetSaveAsFilename(InitialFilename:="SAMPLE.csv", _
FileFilter:=cnsFILTER, Title:=cnsTITLE)
' キャンセルされた場合は以降の処理は行なわない
If StrConv(strFILENAME, vbUpperCase) = "FALSE" Then Exit Sub
' 収容最終行の判定(Excel認知の最終行から上に向かってデータがある行を探す)
GYOMAX = Cells.SpecialCells(xlCellTypeLastCell).Row
Do While Cells(GYOMAX, 1).Value = ""
GYOMAX = GYOMAX - 1
Loop
If GYOMAX < 1 Then
xlAPP.StatusBar = False
MsgBox "テキストをA〜H列1行目から入力してから起動して下さい。",, cnsTITLE
Exit Sub
End If
' FreeFile値の取得(以降この値で入出力する)
intFF = FreeFile
' 指定ファイルをOPEN(出力モード)
Open strFILENAME For Output As #intFF
' 1行目から開始
GYO = 1
' 最終行まで繰り返す
Do Until GYO > GYOMAX
Erase X ' 初期化
' A〜H列内容をレコードにセット(先頭は1行目)
For COL = 1 To 8
X(COL) = FP_CutInjusticeChar(Cells(GYO, COL).Value)
Next COL
' レコード件数カウンタの加算
lngREC = lngREC + 1
xlAPP.StatusBar = "出力中です．．．．(" & lngREC & "レコード目)"
' レコードを出力
Write #intFF, X(1), X(2), X(3), X(4), X(5), X(6), X(7), X(8)
' 行を加算
GYO = GYO + 1
Loop
' 指定ファイルをCLOSE
Close #intFF
xlAPP.StatusBar = False
' 終了の表示
MsgBox "ファイル出力が完了しました。" & vbCr & _
"レコード件数=" & lngREC & "件", vbInformation, cnsTITLE
End Sub
' CSVテキスト項目に出力できない文字を除去する
Private Function FP_CutInjusticeChar(vntInText As Variant) As Variant
Dim strInText2 As String
Dim POS As Long
Dim strChar As String
Dim strOutText As String
FP_CutInjusticeChar = Empty
' 一旦、文字列に変換する
strInText2 = Trim$(CStr(vntInText))
' ブランクの場合は処理なし
If strInText2 = "" Then Exit Function
' 文字列の桁数分繰り返す
strOutText = ""
For POS = 1 To Len(strInText2)
' 1文字を取り出す
strChar = Mid(strInText2, POS, 1)
' ダブルクォーテーションとCRコードをOMIT
If ((strChar <> vbCr) And (strChar <> """")) Then
strOutText = strOutText & strChar
End If
Next POS
' 元の値が数値の場合はDouble型とする
If IsNumeric(vntInText) = True Then
FP_CutInjusticeChar = CDbl(strOutText)
Else
FP_CutInjusticeChar = strOutText
End If
End Function
|
|
お困りです
- 08/11/4(火) 15:02 -
