スポンサーサイト

上記の広告は1ヶ月以上更新のないブログに表示されています。
新しい記事を書く事で広告が消せます。

bat、VBA情報

作成したツールの内容メモ!
んー最近なにの仕事してるかわかんなくなってきたーw


【batファイル】
①(csvファイル)まとめバッチ
copy *.csv /B all.csv

②(指定samファイル)まとめバッチ
copy JXXXXX000400_KXXXF010X.sam_* /B all.csv

③抜粋バッチ
findstr ""111111" "112222" "113333" "114444"" all.csv > bassui.csv

【エクセルVBA】
①メール自動配信
-----------------------------------------
Sub 削除()
'
' 表示をリセットします
'
Range("A4").Select
Range(Selection, Selection.End(xlDown)).Select
Range("A4:A100").Select
Selection.ClearContents
End Sub


Sub ファイル一覧()
Dim フォルダ名 As String
Dim ファイル名 As String
Dim GYO As Long

'フォルダ名の指定
フォルダ名 = Cells(1, 2).Value & "\"
ファイル名 = Dir$("フォルダ名", vbDirectory)
GYO = 4

' 先頭のファイル名の取得
ファイル名 = Dir(フォルダ名)
' ファイルが見つからなくなるまで繰り返す
Do While ファイル名 <> ""
' 行を加算
Cells(GYO, 1).Value = ファイル名
Cells(GYO, 2).Value = FileDateTime((フォルダ名 & "\" & ファイル名))
GYO = GYO + 1 ' 先頭は4行目
' 次のファイル名を取得
ファイル名 = Dir()
Loop
End Sub
-----------------------------------------

Sub temp_444()
Dim openFileName As Variant ' 添付ファイル名
Dim temp As Variant

' 添付ファイルの選択
openFileName = Application.GetOpenFilename(MultiSelect:=True)
Cells(44, 9).Value = openFileName

End Sub
-----------------------------------------

Option Explicit

'*******************************************************************************
' メール送信(CDO)
'*******************************************************************************
' [引数]
' 1 MailSmtpServer : SMTPサーバ名(又はIPアドレス)
' 2 MailFrom : 送信元アドレス
' 3 MailTo : 宛先アドレス(複数の場合はカンマで区切る)
' 4 MailCc : CCアドレス(複数の場合はカンマで区切る)
' 5 MailBcc : BCCアドレス(複数の場合はカンマで区切る)
' 6 MailSubject : 件名
' 7 MailBody : 本文(改行はvbCrLf付加)
' 8 MailAddFile : 添付ファイル(複数の場合はカンマで区切るか配列渡し) ※Option
' 9 MailCharacter : 文字コード指定(デフォルトはShift-JIS) ※Option
' [戻り値]
' 正常時:"OK", エラー時:"NG"+エラーメッセージ
'*******************************************************************************
Public Function SendMailByCDO(MailSmtpServer As String, _
MailFrom As String, _
MailTo As String, _
MailCc As String, _
MailBcc As String, _
MailSubject As String, _
MailBody As String, _
Optional MailAddFile As Variant, _
Optional MailCharacter As String)
Const cnsOK = "OK"
Const cnsNG = "NG"
Dim objCDO As New CDO.Message
Dim vntFILE As Variant
Dim IX As Long
Dim strCharacter As String, strBody As String, strChar As String

On Error GoTo SendMailByCDO_ERR
SendMailByCDO = cnsNG

' 文字コード指定の確認
If MailCharacter <> "" Then
' 指定ありの場合は指定値をセット
strCharacter = MailCharacter
Else
' 指定なしの場合はShift-JISとする
strCharacter = cdoShift_JIS
End If

' 本文の改行コードの確認
' Lfのみの場合Cr+Lfに変換
strBody = Replace(MailBody, vbLf, vbCrLf)
' 上記で元がCr+Lfの場合Cr+Cr+LfになるのでCr+Lfに戻す
MailBody = Replace(strBody, vbCr & vbCrLf, vbCrLf)

With objCDO
With .Configuration.Fields ' 設定項目
.Item(cdoSendUsingMethod) = cdoSendUsingPort ' 外部SMTP指定
.Item(cdoSMTPServer) = MailSmtpServer ' SMTPサーバ名
.Item(cdoSMTPServerPort) = 25 ' ポート№
.Item(cdoSMTPConnectionTimeout) = 60 ' タイムアウト
.Item(cdoSMTPAuthenticate) = cdoAnonymous ' 0
.Item(cdoLanguageCode) = strCharacter ' 文字セット指定
.Update ' 設定を更新
End With
.MimeFormatted = True
.Fields.Update
.From = MailFrom ' 送信者
.To = MailTo ' 宛先
If MailCc <> "" Then .CC = MailCc ' CC
If MailBcc <> "" Then .BCC = MailBcc ' BCC
.Subject = MailSubject ' 件名
.TextBody = MailBody ' 本文
.TextBodyPart.Charset = strCharacter ' 文字セット指定(本文)
' 添付ファイルの登録(複数対応)
If ((VarType(MailAddFile) <> vbError) And _
(VarType(MailAddFile) <> vbBoolean) And _
(VarType(MailAddFile) <> vbEmpty) And _
(VarType(MailAddFile) <> vbNull)) Then
If IsArray(MailAddFile) Then
For IX = LBound(MailAddFile) To UBound(MailAddFile)
.AddAttachment MailAddFile(IX)
Next IX
ElseIf MailAddFile <> "" Then
vntFILE = Split(CStr(MailAddFile), ",")
For IX = LBound(vntFILE) To UBound(vntFILE)
If Trim(vntFILE(IX)) <> "" Then
.AddAttachment Trim(vntFILE(IX))
End If
Next IX
End If
End If
.Send ' 送信
End With
Set objCDO = Nothing
SendMailByCDO = cnsOK
Exit Function

'-------------------------------------------------------------------------------
SendMailByCDO_ERR:
SendMailByCDO = cnsNG & Err.Number & " " & Err.Description
On Error Resume Next
Set objCDO = Nothing
End Function
-------------------------------------------------------------------------------

Option Explicit

'*******************************************************************************
' メール送信テストプログラム
'*******************************************************************************
Sub TEST3()
Dim MailSmtpServer As String ' SMTPサーバ
Dim MailFrom As String ' 発信者
Dim MailTo As String ' 宛先
Dim MailSubject As String ' 件名
Dim MailBody As String ' 本文
Dim MailAddFile As String ' 添付ファイル名(1ファイルのみ対応)
Dim strMSG As String ' 結果メッセージ
Dim strMSG2 As String ' 結果メッセージのWORK
Dim GYO As Long, GYOMAX As Long ' 管理表の行

' 送信確認
If MsgBox("メールを送信します。" & vbCr & _
"SMTP,発信者,宛先等は正しいですか?", vbYesNo) <> vbYes Then Exit Sub

'---------------------------------------------------------------------------
' ■[全体の前処理]
' 宛先アドレスの列で最終行を判定
GYOMAX = Range("B65536").End(xlUp).Row
' 処理先頭行
GYO = 3
' 全体に渡って内容が固定となる項目を変数にセット
MailSmtpServer = Cells(1, 4).Text ' SMTPサーバ
MailFrom = Cells(1, 2).Text ' 発信者

'---------------------------------------------------------------------------
' ■[全体の主処理] ※最終行まで繰り返す
Do While GYO <= GYOMAX
'-----------------------------------------------------------------------
' 分かりやすいようにセル値を一旦、変数にセット
If Cells(GYO, 1).Text <> "" Then
MailTo = Cells(GYO, 1).Text & _
" <" & Cells(GYO, 2).Text & ">" ' 宛先名+アドレス
Else
MailTo = Cells(GYO, 2).Text ' 宛先アドレスのみ
End If
Application.StatusBar = MailTo & " 送信中....( " & GYO - 2 & _
" / " & GYOMAX - 2 & " )"
MailSubject = Cells(GYO, 3).Text ' 件名
' MailBody = Cells(GYO, 4).Text ' 本文(Textは長文不可!)
MailBody = Cells(GYO, 4).Value ' 本文
MailAddFile = Cells(GYO, 5).Text ' 添付ファイル名
'-----------------------------------------------------------------------
' 送信プロシージャの呼び出し(CC,BCCはブランク固定)
' ※ここで組み込みモジュール(modSendMailByCDOn.bas)が呼び出されます。
strMSG2 = SendMailByCDO(MailSmtpServer, MailFrom, MailTo, "", "", _
MailSubject, MailBody, MailAddFile)
' 文字コードを指定する場合は以下のように変更します。(ISO2022JPの例)
' strMSG2 = SendMailByCDO(MailSmtpServer, MailFrom, MailTo, "", "", _
MailSubject, MailBody, MailAddFile, cdoISO_2022_JP)
'-----------------------------------------------------------------------
' 送信不成功の場合はエラーメッセージを集積
If strMSG2 <> "OK" Then
If strMSG <> "" Then strMSG = strMSG & vbCr
strMSG = strMSG & strMSG2 & " (" & MailTo & ")"
End If
'-----------------------------------------------------------------------
' 次行をセット
GYO = GYO + 1
Loop

'---------------------------------------------------------------------------
' ■[全体の後処理]
Application.StatusBar = False
' 送信不成功の場合はエラーメッセージを表示
If strMSG <> "" Then
MsgBox strMSG, vbExclamation
Else
MsgBox "送信処理が完了しました。", vbInformation
End If
End Sub

'-----------------------------<< End of Source >>-------------------------------





②ファイル移動
Option Explicit
'*******************************************************************************
' 「ファイル移動」ボタン(Click)
'*******************************************************************************
Private Sub CommandButton1_Click()
MkDir "\\G\共有フォルダ\フォルダ\101AAA\"
MkDir "\\G\共有フォルダ\フォルダ\102BBB\"
MkDir "\\G\共有フォルダ\フォルダ\103CCC\"

' 元ファイル
Const cnsSOUR1 = "\\G\共有フォルダ\フォルダ\HXXXXXXXXX_INFO.sam_11101*"
' 先フォルダ(右端\必須)
Const cnsDEST1 = "\\G\共有フォルダ\フォルダ\101AAA\"

' 元ファイル
Const cnsSOUR2 = "\\G\共有フォルダ\フォルダ\HXXXXXXXXX_INFO.sam_11102*"
' 先フォルダ(右端\必須)
Const cnsDEST2 = "\\G\共有フォルダ\フォルダ\102BBB\"

' 元ファイル
Const cnsSOUR3 = "\\G\共有フォルダ\フォルダ\HXXXXXXXXX_INFO.sam_11103*"
' 先フォルダ(右端\必須)
Const cnsDEST3 = "\\G\共有フォルダ\フォルダ\103CCC\"

' 元ファイル
Const cnsSOUR43 = "\\G\共有フォルダ\フォルダ\JXXXXX_INFO.sam_21201*"
' 先フォルダ(右端\必須)
Const cnsDEST43 = "\\G\共有フォルダ\フォルダ\101AAA\"

' 元ファイル
Const cnsSOUR44 = "\\G\共有フォルダ\フォルダ\JXXXXX_INFO.sam_11102*"
' 先フォルダ(右端\必須)
Const cnsDEST44 = "\\G\共有フォルダ\フォルダ\102BBB\"

' 元ファイル
Const cnsSOUR45 = "\\G\共有フォルダ\フォルダ\JXXXXX_INFO.sam_11103*"
' 先フォルダ(右端\必須)
Const cnsDEST45 = "\\G\共有フォルダ\フォルダ\103CCC\"

' FSO
Dim objFSO As FileSystemObject
Set objFSO = New FileSystemObject
' FSOによるファイル移動
objFSO.MoveFile cnsSOUR1, cnsDEST1
objFSO.MoveFile cnsSOUR2, cnsDEST2
objFSO.MoveFile cnsSOUR3, cnsDEST3

objFSO.MoveFile cnsSOUR43, cnsDEST43
objFSO.MoveFile cnsSOUR44, cnsDEST44
objFSO.MoveFile cnsSOUR45, cnsDEST45

Set objFSO = Nothing

MsgBox "ファイルの移動が終了しました"

End Sub

'----------------------------<< End of Source >>--------------------------------



③圧縮
'*******************************************************************************
' ZIPファイル圧縮機能のサンプル(要modArchiveBySevenZip32.bas)
' 【前提条件】「7-zip32.dll」を「c:\windows\system32\」直下に置くこと。
'*******************************************************************************
Option Explicit
'*******************************************************************************
' 「圧縮処理開始」ボタン(Click)
'*******************************************************************************
Private Sub CommandButton1_Click()
'---------------------------------------------------------------------------
Dim strPath1 As String, strPath2 As String, i As Long
Dim strMSG As String

i = 2

Do

' 対象フォルダ/ファイル名
strPath1 = Trim(Cells(i, 3).Value)
' ZIP圧縮ファイル名
strPath2 = Trim(Cells(i, 10).Value)
' ZIP圧縮処理を呼び出す
If Not modArchiveBySevenZip32.ArchiveBySevenZip32(strPath1, _
strPath2, _
Application.Caption, _
strMSG) Then
MsgBox strMSG, vbCritical
End If
i = i + 1
Loop While i < 44

MsgBox "圧縮が終了しました"

End Sub
'-----------------------------<< End of Source >>-------------------------------


④ファイル作成日、更新日の取得
Sub 削除()
' 表示をリセットします
' 例:「C6セル」「=MID(A6,17,3)」、「D6セル」「=MID(A6,29,12)」、「E6セル」「=TEXT(D6,"0000!/00!/00! 00!:00")」
Range("A3").Select
Range(Selection, Selection.End(xlDown)).Select
Range("A3:A100").Select
Selection.ClearContents
End Sub

Sub ファイル一覧()
Dim フォルダ名 As String
Dim ファイル名 As String
Dim intFF As Integer ' FreeFile値
Dim strREC As String ' 読み込んだレコード内容
Dim GYO As Long ' 収容するセルの行

MsgBox "ファイル作成日、更新日の取得します!"

'フォルダ名の指定
フォルダ名 = ActiveWorkbook.Path & "\"

' 先頭のファイル名の取得
ファイル名 = Dir(フォルダ名)

' FreeFile値の取得(以降この値で入出力する)
intFF = FreeFile ' ④
GYO = 4

' ファイルが見つからなくなるまで繰り返す
Do While ファイル名 <> "ファイル作成日取得エクセル.xlsm"

' 指定ファイルをOPEN(入力モード)
Open ((フォルダ名 & "\" & ファイル名)) For Input As #intFF ' ⑤

' 改行までをレコードとして読み込む
Line Input #1, strREC ' ⑦

' 例:「I6セル」「=IF(COUNTIF(C3:C200,101)>0,COUNTIF(C3:C200,101),"-")」、「J6セル」「=IF(COUNTIF($C$3:$C$200,101)>0,INDEX($E$3:$E$200,MATCH("101",$C$3:$C$200,0)),"-")」、「K6セル」「=IF(COUNTIF($C$3:$C$200,101)>0,INDEX($B$3:$B$200,MATCH("101",$C$3:$C$200,0)),"-")」表示をユーザー定義「yyyy/m/d h:mm」
' 行を加算しA列にレコード内容を表示(先頭は2行目)
GYO = GYO + 1
Cells(GYO, 1).Value = strREC ' ⑧
Cells(GYO, 2).Value = FileDateTime((フォルダ名 & "\" & ファイル名))

' 指定ファイルをCLOSE
Close #intFF ' ⑨
' 次のファイル名を取得
ファイル名 = Dir()
Loop

End Sub




⑤コード番号によりファイル自動分割
' (置換 close → close SaveChanges:=True)により保存時確認なし

Sub 市()

元シート = "抽出シート" ' 抽出するシート名を指定
キー位置 = "b1" '
キー列 = Sheets("設定シート").Cells(7, 3) ' 抽出キーの列を指定
コード位置 = Sheets("設定シート").Cells(2, 32)
コード位置_ダミー = "a1"
貼付位置 = "a1" ' 貼り付け位置を指定
シート作成判定位置 = "a2" '新規シート
コピー元ブック名 = ThisWorkbook.Name

'新規作成したブックにおける抽出シート名
変更シート名 = Sheets("設定シート").Cells(3, 3)

'シートを追加する新規作成ブック

新規作成ブック名1 = Sheets("設定シート").Cells(2, 20)
新規作成ブック名2 = Sheets("設定シート").Cells(3, 20)
新規作成ブック名3 = Sheets("設定シート").Cells(4, 20)

'シートを追加する新規作成ブック_パスのパス

新規作成ブック_パス1 = Sheets("設定シート").Cells(2, 21)
新規作成ブック_パス2 = Sheets("設定シート").Cells(3, 21)
新規作成ブック_パス3 = Sheets("設定シート").Cells(4, 21)


条件1 = "111111" ' 抽出条件を指定
新シート1 = "101●●" ' 貼り付けするシート名を指定
条件2 = "222222"
新シート2 = "102▲▲"
条件3 = "333333"
新シート3 = "103○○"

'101●●の作成
Sheets(元シート).Select ' 抽出するシートを選択する
Range(キー位置).Select ' キー位置(B1)セルを選択する
Selection.AutoFilter ' オートフィルタをリセットする
Selection.AutoFilter Field:=キー列, Criteria1:=条件1
' キー列(B)が 条件1のデータを抽出する
Selection.CurrentRegion.Copy ' 抽出された範囲をコピーする
Sheets(新シート1).Select ' 貼り付けるシートを選択する
Range(貼付位置).PasteSpecial Paste:=xlAll ' 貼付位置(A1)を左上角としてすべて貼り付ける
Range(貼付位置).Select ' 貼付位置(A1)セルを選択する
Selection.CurrentRegion.Select ' 貼り付けられた範囲を選択する


If Sheets("設定シート").Cells(9, 3) = "はい" Then

Set NewBook = Workbooks.Add
NewBook.SaveAs FileName:=新規作成ブック_パス1
シート名 = ActiveSheet.Name

Workbooks(コピー元ブック名).Activate
Worksheets(新シート1).Copy before:=Workbooks(新規作成ブック名1).Sheets(シート名)
Sheets(新シート1).Name = Format(変更シート名)

If Range(コード位置) < "2**" Then
Sheets(変更シート名).Cells(3, 2).Value = "該当者は存在しません。"
End If

Workbooks(新規作成ブック名1).Close


Else
If Range(コード位置) >= "2**" Then
Set NewBook = Workbooks.Add
NewBook.SaveAs FileName:=新規作成ブック_パス1
シート名 = ActiveSheet.Name

Workbooks(コピー元ブック名).Activate
Worksheets(新シート1).Copy before:=Workbooks(新規作成ブック名1).Sheets(シート名)
Sheets(新シート1).Name = Format(変更シート名)

Workbooks(新規作成ブック名1).Close
End If
End If


'102▲▲の作成
Sheets(元シート).Select
Range(キー位置).Select
Selection.AutoFilter
Selection.AutoFilter Field:=キー列, Criteria1:=条件2
Selection.CurrentRegion.Copy
Sheets(新シート2).Select
Range(貼付位置).PasteSpecial Paste:=xlAll
Range(貼付位置).Select
Selection.CurrentRegion.Select


If Sheets("設定シート").Cells(9, 3) = "はい" Then

Set NewBook = Workbooks.Add
NewBook.SaveAs FileName:=新規作成ブック_パス2
シート名 = ActiveSheet.Name

Workbooks(コピー元ブック名).Activate
Worksheets(新シート2).Copy before:=Workbooks(新規作成ブック名2).Sheets(シート名)
Sheets(新シート2).Name = Format(変更シート名)

If Range(コード位置) < "2**" Then
Sheets(変更シート名).Cells(3, 2).Value = "該当者は存在しません。"
End If

Workbooks(新規作成ブック名2).Close


Else
If Range(コード位置) >= "2**" Then
Set NewBook = Workbooks.Add
NewBook.SaveAs FileName:=新規作成ブック_パス2
シート名 = ActiveSheet.Name

Workbooks(コピー元ブック名).Activate
Worksheets(新シート2).Copy before:=Workbooks(新規作成ブック名2).Sheets(シート名)
Sheets(新シート2).Name = Format(変更シート名)

Workbooks(新規作成ブック名2).Close
End If
End If


'103○○の作成
Sheets(元シート).Select
Range(キー位置).Select
Selection.AutoFilter
Selection.AutoFilter Field:=キー列, Criteria1:=条件3
Selection.CurrentRegion.Copy
Sheets(新シート3).Select
Range(貼付位置).PasteSpecial Paste:=xlAll
Range(貼付位置).Select
Selection.CurrentRegion.Select

If Sheets("設定シート").Cells(9, 3) = "はい" Then

Set NewBook = Workbooks.Add
NewBook.SaveAs FileName:=新規作成ブック_パス3
シート名 = ActiveSheet.Name

Workbooks(コピー元ブック名).Activate
Worksheets(新シート3).Copy before:=Workbooks(新規作成ブック名3).Sheets(シート名)
Sheets(新シート3).Name = Format(変更シート名)

If Range(コード位置) < "2**" Then
Sheets(変更シート名).Cells(3, 2).Value = "該当者は存在しません。"
End If

Workbooks(新規作成ブック名3).Close


Else
If Range(コード位置) >= "2**" Then
Set NewBook = Workbooks.Add
NewBook.SaveAs FileName:=新規作成ブック_パス3
シート名 = ActiveSheet.Name

Workbooks(コピー元ブック名).Activate
Worksheets(新シート3).Copy before:=Workbooks(新規作成ブック名3).Sheets(シート名)
Sheets(新シート3).Name = Format(変更シート名)

Workbooks(新規作成ブック名3).Close
End If
End If
End Sub

------------------------------------------------------------
Sub データ消去()

Sheets("抽出シート").Select
Selection.AutoFilter
Cells.Select
Selection.ClearContents
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
Selection.Borders(xlEdgeLeft).LineStyle = xlNone
Selection.Borders(xlEdgeTop).LineStyle = xlNone
Selection.Borders(xlEdgeBottom).LineStyle = xlNone
Selection.Borders(xlEdgeRight).LineStyle = xlNone
Selection.Borders(xlInsideVertical).LineStyle = xlNone
Selection.Borders(xlInsideHorizontal).LineStyle = xlNone


'1 101●●
Sheets("101●●").Select
Cells.Select
Selection.ClearContents
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
Selection.Borders(xlEdgeLeft).LineStyle = xlNone
Selection.Borders(xlEdgeTop).LineStyle = xlNone
Selection.Borders(xlEdgeBottom).LineStyle = xlNone
Selection.Borders(xlEdgeRight).LineStyle = xlNone
Selection.Borders(xlInsideVertical).LineStyle = xlNone
Selection.Borders(xlInsideHorizontal).LineStyle = xlNone


'2 102▲▲
Sheets("102▲▲").Select
Cells.Select
Selection.ClearContents
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
Selection.Borders(xlEdgeLeft).LineStyle = xlNone
Selection.Borders(xlEdgeTop).LineStyle = xlNone
Selection.Borders(xlEdgeBottom).LineStyle = xlNone
Selection.Borders(xlEdgeRight).LineStyle = xlNone
Selection.Borders(xlInsideVertical).LineStyle = xlNone
Selection.Borders(xlInsideHorizontal).LineStyle = xlNone

'3 103○○
Sheets("103○○").Select
Cells.Select
Selection.ClearContents
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
Selection.Borders(xlEdgeLeft).LineStyle = xlNone
Selection.Borders(xlEdgeTop).LineStyle = xlNone
Selection.Borders(xlEdgeBottom).LineStyle = xlNone
Selection.Borders(xlEdgeRight).LineStyle = xlNone
Selection.Borders(xlInsideVertical).LineStyle = xlNone
Selection.Borders(xlInsideHorizontal).LineStyle = xlNone

Sheets("設定シート").Select

End Sub
----------------------------------------------

Sub 列幅補正()

Sheets("抽出シート").Select
Cells.Select
Selection.Copy
Range("A1").Select
'1 101●●
Sheets("101●●").Select
Cells.Select
Selection.PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Range("A1").Select
'2 102▲▲
Sheets("102▲▲").Select
Cells.Select
Selection.PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Range("A1").Select
'3 103○○
Sheets("103○○").Select
Cells.Select
Selection.PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Range("A1").Select

Sheets("設定シート").Select
End Sub
------------------------------------------------

Sub パスの取得()
Dim FileName As Variant
FileName = Application.GetSaveAsFilename _

If FileName = False Then Exit Sub
Sheets("設定シート").Cells(12, 3).Value = Mid(FileName, 1, _
InStrRev(FileName, "\") - 1)
End Sub



















コメント

Secret

プロフィール

紅玉春花

Author:紅玉春花
いらっしゃいましー(≧▽≦)
動画倉庫

mineo紹介URL(1,000円ギフト付)

最新コメント
カテゴリ
FC2カウンター
三國志Online・ブログ
検索フォーム
リンク
上記広告は1ヶ月以上更新のないブログに表示されています。新しい記事を書くことで広告を消せます。