|
|
| |
|
|
| |
| Page Index |
| （入出力の準備） |
|
|
| （ファイルの入力） |
|
|
| （ファイルの作成） |
|
|
| （その他の操作） |
|
|
|
| |
| 本章では、ファイル操作に関するコードサンプルを例示します。 |
| （入出力の準備） |
|
|
|
Dim mypath As String
mypath = ActiveWorkbook.Path & "\"
|
|
|
|
|
|
Dim flName As String
flName = ActiveWorkbook.Name |
| |
|
|
|
Dim DirectoryExist, DirectoryPath As String
DirectoryPath = "C:\・・・・・"
DirectoryExist = Dir(DirectoryPath, vbDirectory)
フォルダーが存在しない場合はDir関数はnullを返します |
|
| |
|
|
|
|
If Dir("D:\Book1.xls") <> "" Then
MsgBox "Book1 は存在します。", vbInformation
Else
MsgBox "Book1 は存在しません。", vbInformation
End If |
| |
|
|
|
|
Option Explicit
Dim myPath As String 'ファイルのパス名
Dim flName As String 'ファイルのファイル名
Sub Disp()
Dim getfile As Variant '固定長ファイル名
Dim st1, posMj As Integer
myPath = ""
flName = ""
'ダイアログボックスにてファイル名取得
ChDir "C:\WINDOWS\ﾃﾞｽｸﾄｯﾌﾟ" '任意
getfile = Application.GetOpenFilename("ﾃｷｽﾄ ﾌｧｲﾙ (*.txt), *.txt",
, "ファイル名の指定")
If getfile = False Then Exit Sub
'パス名とファイル名に分離
st1 = 1
Do Until st1 = 0
posMj = st1 '\の位置
st1 = st1 + 1
st1 = InStr(st1, getfile, "\", 1)
Loop
myPath = Mid(getfile, 1, posMj)
flName = Mid(getfile, posMj + 1, Len(getfile) - posMj)
End Sub |
|
|
|
|
|
こちらのサイトを参照してください ： ☆ Excelでお仕事！(Excel全般の解説サイト) ☆ |
| |
|
|
|
Sub CSVファイルを開くダイアログボックスを表示する()
Dim getfile As Variant
getfile = Application.GetOpenFilename("CSV
ﾌｧｲﾙ (*.csv), *.csv", , "Justファイルの参照")
If getfile = False Then Exit Sub
End Sub |
|
|
|
|
|
ChDir "C:\WINDOWS\ﾃﾞｽｸﾄｯﾌﾟ" |
| |
|
|
|
Const cnsTARG As String = "C:\Documents
and Settings\nobuyuki\デスクトップ\a.txt"
' 元ファイル
Const cnsDEST As String = "C:\Documents
and Settings\nobuyuki\デスクトップ\b.txt"
' 先ファイル
FileCopy cnsTARG, cnsDEST 'ファイルをコピーする
Kill cnsTARG ' 元ファイルを削除する |
|
|
| （ファイルの入力） |
|
|
|
Dim n As Long
n = 1
Open "C:\Test.txt" For Input As
#n |
|
|
|
|
|
Workbooks.Open FileName:="c:\.......xls"
Workbooks.Open myPath & myFilename |
|
|
|
|
|
' 改行までをレコードとして読み込む
Sub Sample()
Dim n As Long, buf As
Variant, buf As String
n = 1
Open "C:\Test.txt"
For Input
As #n
Do Until EOF(n)
Input #n, buf
Loop
Close #n
End Sub |
|
| |
|
|
|
Sub Sample()
Dim n As Long
Dim X(1 To 5) As Variant
' 読み込んだレコード内容
n = 1
Open "C:\Test.txt" For Input
As #n
Do Until EOF(n)
Line Input #n, X(1), X(2), X(3), X(4),
X(5) ' 改行までをレコードとして読み込む（このサンプルは5項目のCSV）
Loop
Close #n
End Sub |
|
| |
|
|
|
Sub Sample()
Dim n As Long, buf As
Variant, buf As String
Dim arr As Variant
n = 1
Open "C:\Test.txt" For Input
As #n
Do Until EOF(n)
Input #n, buf ' 改行までをレコードとして読み込む
arr = Split(buf, vbTab)
'タブ区切りで配列に取得
Loop
Close #n
End Sub |
|
| |
|
|
|
Sub CSV_Download()
Dim MyPath As String ' このBOOKのパス名
Dim csvFILENAME As String ' 作成するcsvファイル名(フルパス)
Dim X(1 To 8) As Variant ' 読み込むレコード内容
Dim GYO As Long ' 収容するセルの行(Work)
Dim COL As Long ' 列の位置(Work)
Dim lngREC As Long ' レコード件数カウンタ
' テキストファイル名をセットする
Mypath = ActiveWorkbook.Path
csvFILENAME = Mypath & "\"
& "Denpyo.txt"
' csvファイルをOPEN(入力モード)する
Open csvFILENAME For Input As #1
Worksheets("sheet1").Activate ' シートをactiveにする
lngREC = 0
Do Until EOF(1)
lngREC = lngREC + 1
Input #1, X(1), X(2), X(3), X(4),
X(5), X(6), X(7), X(8) ' レコードを入力する
GYO = lngREC + 2 ' シートの3行目以降に書き込む
For COL = 1 To 8
ActiveSheet.Cells(GYO, COL).Value
= X(COL)
Next COL
Loop
' 作成したcsvファイルをCLOSEする
Close #1
' 終了の表示
MsgBox "ファイル入力が完了しました。"
& vbCr & "レコード件数="
& lngREC & "件"
End Sub
※
EOF関数は、ランダムアクセスモードまたはシーケンシャル入力モードで開いたファイルの現在位置がファイルの末尾に達しているときTrueを返します。（最終のレコードを読んだときにTrueを返す）
EOF(filenumber)
引数fienumberには、現在開いているファイルを表す有効なファイル番号を指定します。 |
|
| |
|
|
|
Data.txt というテキスト ファイルを、タブを区切り文字として分析し、ワークシートに変換する。
Workbooks.OpenText filename:="DATA.TXT",
_
dataType:=xlDelimited, tab:=True |
|
| |
|
|
|
Sub 固定長ファイルをExcelシートに取り込む()
Dim getfile As Variant 'ダイアログボックスから取得したファイル名（パス含む）
Dim myPath As String 'ファイルのパス名
Dim flName As String 'ファイルのファイル名
Dim lastGyo As Integer '項目定義シート"桁数"列の最終行
Dim rlen As Integer 'レコード長
Dim rMax As Long 'レコード件数
Dim mdsYm As Integer '見出し有＝１、無＝０
Const Sheet1 = "使用方法"
Const Sheet2 = "項目定義"
Const Sheet3 = "データシート"
Dim NewBook As Workbook
Dim buf As String 'レコードバッファー
Dim strl As String
Dim i As Long
Dim j As Long
Dim bufPos As Long
Dim celValue As String '項目の値
Dim colLen As Integer '項目の桁数
Dim colUdr As Integer '小数桁数
Reset
'ファイルがあるか確認する
myPath = Sheets(Sheet2).Cells(3, 2)
flName = Sheets(Sheet2).Cells(5, 2)
With Application.FileSearch
.NewSearch
.LookIn = myPath
.SearchSubFolders = True
.Filename = flName
.MatchTextExactly = True
'.FileType = msoFileTypeAllFiles
If .Execute() = 0 Then
MsgBox "ファイルが見つかりません"
Exit Sub
End If
End With
'データシートをクリアする
With Sheets(Sheet3)
.Range(.Cells(1, 1), .Cells.SpecialCells(xlLastCell)).Clear
End With
'項目定義シートの桁数列の最終行を求める
lastGyo = Sheets(Sheet2).Range("E65536").End(xlUp).Row
'レコード長を求める
Call レコード長を求める
'Open myPath & "\" & flName
For Random Access Read As #1 Len = rlen
Open myPath & "\" & flName
For Input Access Read As #1 Len = rlen
'レコード件数を求める
rMax = Fix(LOF(1) / rlen)
'見出しを作成する
i = 1
If mdsYm = 1 Then
For i = 8 To lastGyo
Sheets(Sheet3).Cells(1, i - 7) = Sheets(Sheet2).Cells(i,
3).Value
Next i
End If
'列幅を設定する
i = 1
If mdsYm = 1 Then
For i = 8 To lastGyo
j = i - 7
Sheets(Sheet3).Columns(j).ColumnWidth = Len(Sheets(Sheet2).Cells(i,
3)) * 2
Next i
End If
'データを設定する
For i = 1 To rMax
'Get #1, i, buf
buf = Input(rlen, 1)
bufPos = 1
For j = 1 To 999
colLen = Sheets(Sheet2).Cells(j + 7, 5).Value
'桁数
colUdr = Sheets(Sheet2).Cells(j + 7, 6).Value
'小数桁
If colLen < 1 Then Exit For
celValue = "'" + Mid(buf, bufPos,
colLen) '項目の値
'値のセット
If colUdr > 0 Then '小数桁
Sheets(Sheet3).Cells(i + mdsYm, j).Value
= Mid(celValue, 1, colLen - colUdr + 1) _
& "." & _
Mid(celValue, colLen - colUdr + 2)
Else
Sheets(Sheet3).Cells(i + mdsYm, j).Value
= celValue
End If
bufPos = bufPos + colLen
If bufPos > rlen Then Exit For
Next
Next
'状態を保存する
ActiveWorkbook.Save
'別のブックに保存するか確認する
myPath = Sheets(Sheet2).Cells(3, 8)
flName = Sheets(Sheet2).Cells(5, 8)
If myPath & flName <> ActiveWorkbook.Path
& ActiveWorkbook.Name Then
'別のブックに保存
With Application.FileSearch
.NewSearch
.LookIn = myPath
.SearchSubFolders = True
.Filename = flName
.MatchTextExactly = True
'.FileType = msoFileTypeAllFiles
If .Execute() = 0 Then
'新しく作成
Sheets(Sheet3).Activate
Cells.Select
Application.CutCopyMode = False
Selection.Copy
Set NewBook = Workbooks.Add(xlWBATWorksheet)
NewBook.Sheets(1).Name = Sheet3
NewBook.Sheets(Sheet3).Activate
Cells.Select
'貼り付け（すべて）
Selection.PasteSpecial Paste:=xlAll, Operation:=xlNone,
_
SkipBlanks:=False, Transpose:=False
NewBook.SaveAs Filename:=myPath & "\"
& flName
Workbooks(flName).Close saveChanges:=False
Else
'既存ブックに保存
Sheets(Sheet3).Activate
Cells.Select
Application.CutCopyMode = False
Selection.Copy
Workbooks.Open Filename:=myPath & "\"
& flName
'シートがあるか？？？？？？？？？？？？？？？？？？？？？？
Workbooks(flName).Worksheets(Sheet3).Activate
Cells.Select
'貼り付け（すべて）
Selection.PasteSpecial Paste:=xlAll, Operation:=xlNone,
_
SkipBlanks:=False, Transpose:=False
Workbooks(flName).Close saveChanges:=True
End If
End With
End If
Sheets(Sheet1).Activate
Cells(1.1).Select
MsgBox Str(rMax) + "件作成しました。"
End Sub
Sub レコード長を求める()
Dim myRange As Range '項目定義シートの範囲
Sheets(Sheet2).Activate
Set myRange = Sheets(Sheet2).Range(Cells(8,
5), Cells(lastGyo, 5))
rlen = Application.Sum(myRange)
End Sub |
|
| |
|
|
|
Set newModule = Modules.Add
newModule.InsertFile fileName:="testcode.txt" |
|
| |
| （ファイルの出力） |
|
|
|
Dim n As Long
n = 1
Open "C:\Test.txt" For Output As
#n |
|
| |
|
|
|
Workbooks.Open FileName:="c:\.......xls"
Workbooks.Open myPath & myFilename |
|
| |
|
|
|
Dim strName As String
・
Workbooks.Add '新しいワークブックを作成する
'新しいワークブックを開いた後はアクティブ状態になる
strName = ActiveWorkbook.Name 'ワークブック名をstrNameへ保存する
Workbooks(strName).SaveAs "C:\My Documents\test.xls " 'ワークブックを保存する
Workbooks("test.xls").Close
'ワークブックを閉じる |
| |
|
|
|
Workbooks(oflname).Close saveChanges:=False
セーブ
Workbooks(nflname).SaveAs FileName:=omypath
Workbooks(oflname).Close saveChanges:=True
|
| |
|
|
|
ActiveWorkbook.Save
|
| |
|
|
|
ファイルを削除します.
Kill "TestFile"
カレント ディレクトリにあるすべての *.txt ファイルを削除します.
Kill "*.txt"
ファイルを削除します.
mypath = ActiveWorkbook.Path & "\"
Kill mypath & "宛名.DOC"
|
| |
|
|
|
Sub Sample()
Dim n As Long, buf As Variant,
n = 2
Open "C:\Test.txt" For Output As #n
Print #n, buf ' 一行書き込む
Close #n
End Sub |
| |
|
|
|
Set newModule = Modules.Add
newModule.InsertFile fileName:="testcode.txt" |
|
|
|
|
|
Sub CSV_Download()
'
'ワークシートの内容をCSV形式のテキストファイルに出力する（""付）
'
'以下のパラメータを設定してください
Const File_nm As String = "Denpyo.txt" '← テキストファイル名（拡張子付）
Const Sheet_nm As String = "Sheet1" '← 出力する当該ブックのシート名
Const Row_num As Long = 8 '← 出力するシートの列数
Dim MyPath As String ' このBOOKのパス名
Dim csvFILENAME As String ' 作成するcsvファイル名(フルパス)
Dim X() As String ' 書き出すレコードの内容
Dim GYOMAX As Long ' データが収容された最終行
Dim GYO As Long ' 収容するセルの行(Work)
Dim COL As Long ' 列の位置(Work)
Dim lngREC As Long ' レコード件数カウンタ
ReDim X(Row_num)
' テキストファイル名をセットする
MyPath = ActiveWorkbook.Path
csvFILENAME = MyPath & "\" & File_nm
'シートの最終行を求める
Worksheets(Sheet_nm).Activate ' シートをactiveにする
ActiveSheet.UsedRange.Select ' シートの有効行を選択する
GYOMAX = Selection.Rows.Count '「GYOMAX」に最終行をセットする
' 作成するcsvファイルをOPEN(出力モード)する
Open csvFILENAME For Output As #1
' シートの1行目（1〜n列）から最終行までをテキストファイルに出力する
For GYO = 1 To GYOMAX
For COL = 1 To 8
X(COL) = "" & ActiveSheet.Cells(GYO, COL).Value & ""
Next COL
For i = 1 To Row_num - 1 ' レコードを出力
Write #1, X(i); '改行を阻止するため後ろに 「;」を付ける
Next
Write #1, X(Row_num)
lngREC = lngREC + 1 ' レコード件数カウンタの加算
Next
' 作成したcsvファイルをCLOSEする
Close #1
' 終了の表示
MsgBox "ファイル出力が完了しました。" & vbCr & "レコード件数=" & lngREC & "件"
End Sub |
| |
| （その他の操作） |
|
|
|
Dim myNo As Integer
Dim myMsg As String,myTitle As String
mymsg = "売上No.を指定してください"
myTitle = "売上データ削除"
myNo = Val(InputBox(Prompt:=myMsg, _
Title:=myTitle))
If myNo <> 0 Then
MsgBox myNo & "を削除します"
Else
MsgBox "削除処理はキャンセルされました"
End If |
|
| |
|
|
|
MsgBox "日付が入力されていません。"
& Chr(13) & Chr(10) & _
"記録がない場合は、" &
Date & "を入力して下さい。"
If MsgBox("ファイル更新しますか？",
vbYesNo) = vbYes Then
MsgBox "日付が入力されていません。
End If |
|
| |
|
|
|
メモ帳を起動する
Sub memo()
Dim RV
RV = Shell("NOTEPAD.EXE", 1)
AppActivate RV 'アクティブにする
End Sub
電卓を起動する
Sub memo()
Dim RV
RV = Shell("CALC.EXE", 1)
AppActivate RV 'アクティブにする
End Sub
テキストファイルを開く
Sub memo()
Call Shell("NOTEPAD C:\Temp\sample.txt", 1)
End Sub
ワードファイルを開く
Sub memo()
Call Shell("WINWORD.EXE C:\Temp\sample.doc", 1)
End Sub
パワーポイントファイルを開く
Sub memo()
Call Shell("POWERPNT.EXE C:\Temp\sample.ppt", 1)
End Sub
URLを指定してＩＥを起動する
Sub url()
Dim objIE As Object 'ＩＥ参照用オブジェクト
Set objIE = CreateObject("InternetExplorer.application") 'IEのオブジェクトを作る
objIE.Visible = True '見えるようにする
objIE.Navigate "http://・・・・" '.URLを開く
End Sub
|
|
|
|
|
|
'Excelブックをメールに添付して送信する
ActiveWorkbook.SendMail Recipients:="xxxx@xxxxxxxx", Subject:="test" |
| |
|
|
|
Webサイトの情報を入手する
Dim HTTP As Object
Set HTTP = CreateObject("MSXML2.XMLHTTP") 'MSXML2.XMLHTTPオブジェクトを生成する
targetURI, = "http:// ・・・ " 'アクセスするURLをセット
HTTP.Open "GET", targetURI, False
HTTP.Send
Buf = StrConv(HTTP.ResponseBody, vbUnicode)
Set Http = Nothing
文字コードが Shift-JIS であれば'StrConv 関数で Unicode に変換できるが、EUC や JIS の場合は'NKF32.DLL などでいったん Shift-JIS に変換してやる必要があります。 |
|
|
|
|
|
Sub DocActivate()
Dim wb As Workbook
For Each wb In Workbooks
If wb.Name = "Excel1.xls" Then Windows("Excel1.xls").Activate
Next wb
End Sub
Sub WbActivate2()
Workbooks("Excel1.xls").Activate
End Sub |
