Excel VBA 質問スレッド No.30 (解決済)

どの端末でもデスクトップのファイルをリネームしてインポートしたい

投稿者 : ゆうきや     投稿日時 : 2017/05/11(Thu) 08:47:42     OS : Windows 7     EXCEL : Excel 2010
再度の投稿となります。
よろしくお願い致します。

以下のようなVBAがあります。

・tanakaさんのデスクトップ上のmeisai.datをmeisai.csvにリネーム
・meisai.csvからインポートして、内線マスタの表を参照してvlookでデータをworkに抽出
・最終的にworkのデータを通話明細にコピペ

以上の動きをします。

<質問>
現在、tanakaさんのデスクトップ上のmesai.datファイルを処理していますが
これを『誰のデスクトップに置かれているmeisai.datでも処理ができるように』したいです。
どこを修正すれば「誰の(どの端末)デスクトップ上でも作業ができるようになるか」を
ご教授していただきたく、投稿致しました。

よろしくお願い致します。

<既存VBA>
Sub meisai_import()
'
' meisai_import Macro
'

'

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual


'拡張子を変更・保存(meisai.dat ⇒ meisai.csv)
Const OLD_EXTENSION As String = "meisai.dat"
Const NEW_EXTENSION As String = "meisai.csv"

Const SAVE_DIR As String = "C:\Users\tanaka\Desktop\" ← どの端末のデスクトップでも処理がでいるようにしたい

Dim OldFName As String
Dim NewFName As String

OldFName = Dir(SAVE_DIR & "*" & OLD_EXTENSION)

Do While Len(OldFName) <> 0
OldFName = SAVE_DIR & OldFName
NewFName = _
Left(OldFName, Len(OldFName) - Len(OLD_EXTENSION)) & NEW_EXTENSION

FileCopy OldFName, NewFName
Kill OldFName
OldFName = Dir()
Loop


'初期化(行削除)
Range("A2", Cells(Rows.Count, 1).End(xlDown)).EntireRow.Delete


'デスクトップ上のDWLファイル(meisai.csv)をインポート
With ActiveSheet.QueryTables.Add(Connection:= _
"TEXT;C:\Users\bldmonden\Desktop\meisai.csv", Destination:=Range("$A$2"))
.Name = "meisai"
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False

'既存のセルを新規データで上書き
.RefreshStyle = xlOverwriteCells
.SavePassword = False
.SaveData = True

'文字の長さで列幅調整
.AdjustColumnWidth = True
.RefreshPeriod = 0
.TextFilePromptOnRefresh = False
.TextFilePlatform = 932
.TextFileStartRow = 1
.TextFileParseType = xlDelimited
.TextFileTextQualifier = xlTextQualifierDoubleQuote
.TextFileConsecutiveDelimiter = True
.TextFileTabDelimiter = True
.TextFileSemicolonDelimiter = False
.TextFileCommaDelimiter = True
.TextFileSpaceDelimiter = True
.TextFileColumnDataTypes = Array(2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2)
.TextFileTrailingMinusNumbers = True
.Refresh BackgroundQuery:=False

End With


'work sheet作成
Worksheets.Add(after:=Worksheets(Worksheets.Count)).Name = "work"

Application.Goto Sheets("work").Range("A1")


'内線マスタ(内線番号)から部屋名を取得
Sheets("通話明細").Select


'内線番号の取得範囲設定(データのある最終行まで)
Range(Range("D2"), Cells(Rows.Count, 4).End(xlUp)).Copy
Application.Goto Sheets("work").Range("A1")


'内線番号をworkにペースト・接頭辞(')の削除
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlAdd, SkipBlanks _
:=False, Transpose:=False

Sheets("通話明細").Select
Application.CutCopyMode = False


'内線番号を参照して、部屋名称を取得
Sheets("work").Select

Application.Goto Sheets("work").Range("B1")

Dim naisen_LastRow As Long
Dim work_LastRow As Long
Dim number As Long

'内線マスタシートのA列(内線番号)最終行
naisen_LastRow = Worksheets("内線マスタ").Cells(Rows.Count, 1).End(xlUp).Row

'ワークシートのA列(内線番号)最終行
work_LastRow = Worksheets("work").Cells(Rows.Count, 1).End(xlUp).Row

'ワークシートのA列1行目から最終行まで繰り返し
For number = 1 To work_LastRow

Worksheets("work").Cells(number, 2).FormulaR1C1 = _
"=IF(RC[-1]="""","""",(VLOOKUP(RC[-1],内線マスタ! R1C1:R" & naisen_LastRow & "C2,2,FALSE)))"
Next number


'部屋名称の取得結果を「通話明細」シートのE列にコピペ
Range(Range("B1"), Cells(Rows.Count, 2).End(xlUp)).Copy

Sheets("通話明細").Select

Range("E2").Select '1列目は「項目」

Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False

Range("A1").Select


'データの存在する列・行まで罫線を引く(途中に空白行が存在しないこと)
Dim i As Integer
Dim j As Integer

i = Cells(Rows.Count, 1).End(xlUp).Row
j = Cells(1, Columns.Count).End(xlToLeft).Column

Range(Cells(1, 1), Cells(i, j)).Borders.LineStyle = xlContinuous


'work sheet削除
Application.Goto Sheets("work").Range("A1")
Application.CutCopyMode = False

Sheets("work").Select

Application.DisplayAlerts = False
ActiveSheet.Delete
Application.DisplayAlerts = True

Sheets("通話明細").Select

Range("A1").Select

Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True

End Sub

[返信 1] Re : どの端末でもデスクトップのファイルをリネームしてインポートしたい
投稿者 : 管理人     投稿日時 : 2017/05/11(Thu) 23:28:14
先月末のやりとりをもとに微修正したものを掲載します。
これでどこまで動くか教えてください。


Sub meisai_import()
'
' meisai_import Macro
'

'

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual


'拡張子を変更・保存(meisai.dat ⇒ meisai.csv)
Const OLD_EXTENSION As String = "meisai.dat"
Const NEW_EXTENSION As String = "meisai.csv"

'Const SAVE_DIR As String = "C:\Users\tanaka\Desktop\"
Dim SAVE_DIR As String
Dim wsh As Object
Set wsh = CreateObject("Wscript.Shell")
SAVE_DIR = wsh.SpecialFolders("Desktop") & "\"
Set wsh = Nothing

Dim OldFName As String
Dim NewFName As String

OldFName = Dir(SAVE_DIR & "*" & OLD_EXTENSION)

Do While Len(OldFName) <> 0
OldFName = SAVE_DIR & OldFName
NewFName = _
Left(OldFName, Len(OldFName) - Len(OLD_EXTENSION)) & NEW_EXTENSION

FileCopy OldFName, NewFName
Kill OldFName
OldFName = Dir()
Loop


'初期化(行削除)
Range("A2", Cells(Rows.Count, 1).End(xlDown)).EntireRow.Delete


'デスクトップ上のDWLファイル(meisai.csv)をインポート
With ActiveSheet.QueryTables.Add(Connection:= _
"TEXT;" & SAVE_DIR & "meisai.csv", Destination:=Range("$A$2"))
.Name = "meisai"
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False

'既存のセルを新規データで上書き
.RefreshStyle = xlOverwriteCells
.SavePassword = False
.SaveData = True

'文字の長さで列幅調整
.AdjustColumnWidth = True
.RefreshPeriod = 0
.TextFilePromptOnRefresh = False
.TextFilePlatform = 932
.TextFileStartRow = 1
.TextFileParseType = xlDelimited
.TextFileTextQualifier = xlTextQualifierDoubleQuote
.TextFileConsecutiveDelimiter = True
.TextFileTabDelimiter = True
.TextFileSemicolonDelimiter = False
.TextFileCommaDelimiter = True
.TextFileSpaceDelimiter = True
.TextFileColumnDataTypes = Array(2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2)
.TextFileTrailingMinusNumbers = True
.Refresh BackgroundQuery:=False

End With


'work sheet作成
Worksheets.Add(after:=Worksheets(Worksheets.Count)).Name = "work"

Application.Goto Sheets("work").Range("A1")


'内線マスタ(内線番号)から部屋名を取得
Sheets("通話明細").Select


'内線番号の取得範囲設定(データのある最終行まで)
Range(Range("D2"), Cells(Rows.Count, 4).End(xlUp)).Copy
Application.Goto Sheets("work").Range("A1")


'内線番号をworkにペースト・接頭辞(')の削除
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlAdd, SkipBlanks _
:=False, Transpose:=False

Sheets("通話明細").Select
Application.CutCopyMode = False


'内線番号を参照して、部屋名称を取得
Sheets("work").Select

Application.Goto Sheets("work").Range("B1")

Dim naisen_LastRow As Long
Dim work_LastRow As Long
Dim number As Long

'内線マスタシートのA列(内線番号)最終行
naisen_LastRow = Worksheets("内線マスタ").Cells(Rows.Count, 1).End(xlUp).Row

'ワークシートのA列(内線番号)最終行
work_LastRow = Worksheets("work").Cells(Rows.Count, 1).End(xlUp).Row

'ワークシートのA列1行目から最終行まで繰り返し
For number = 1 To work_LastRow

Worksheets("work").Cells(number, 2).FormulaR1C1 = _
"=IF(RC[-1]="""","""",(VLOOKUP(RC[-1],内線マスタ! R1C1:R" & naisen_LastRow & "C2,2,FALSE)))"
Next number


'部屋名称の取得結果を「通話明細」シートのE列にコピペ
Range(Range("B1"), Cells(Rows.Count, 2).End(xlUp)).Copy

Sheets("通話明細").Select

Range("E2").Select '1列目は「項目」

Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False

Range("A1").Select


'データの存在する列・行まで罫線を引く(途中に空白行が存在しないこと)
Dim i As Integer
Dim j As Integer

i = Cells(Rows.Count, 1).End(xlUp).Row
j = Cells(1, Columns.Count).End(xlToLeft).Column

Range(Cells(1, 1), Cells(i, j)).Borders.LineStyle = xlContinuous


'work sheet削除
Application.Goto Sheets("work").Range("A1")
Application.CutCopyMode = False

Sheets("work").Select

Application.DisplayAlerts = False
ActiveSheet.Delete
Application.DisplayAlerts = True

Sheets("通話明細").Select

Range("A1").Select

Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True

End Sub

[返信 2] Re : どの端末でもデスクトップのファイルをリネームしてインポートしたい
投稿者 : ゆうきや     投稿日時 : 2017/05/12(Fri) 10:02:05
管理人様

早々のご返信、ありがとうございました。
お陰様で、エラーなく結果を取得することができました。

勉強不足で、済みません。
以下の構文について、少々説明を頂けたらと思います。
前回、「SAVE ~ ("Desktop")」の後に「& "\"」を付けていませんでした。

-----------------------------------------------------
Dim SAVE_DIR As String
Dim wsh As Object
Set wsh = CreateObject("Wscript.Shell")
SAVE_DIR = wsh.SpecialFolders("Desktop") & "\"
Set wsh = Nothing
-----------------------------------------------------

お忙し中、申し訳ありません。今ひとつ理解できなかったので。

[返信 3] Re : どの端末でもデスクトップのファイルをリネームしてインポートしたい
投稿者 : 管理人     投稿日時 : 2017/05/12(Fri) 23:36:09
その部分は前回返信があったように
ログインユーザーのデスクトップのパスを取得する処理になります。

[返信 4] Re : どの端末でもデスクトップのファイルをリネームしてインポートしたい
投稿者 : ゆうきや     投稿日時 : 2017/05/16(Tue) 15:46:55
管理人様

ご返信、ありがとうございます。

理解できているようで、まだまだでした。
ありがとうございました。

また、投稿させていただく機会がありましたら、よろしくお願いいたします。

スポンサード リンク
 
 
当掲示板について
返信入力フォーム
お 名 前  :
内  容   :
ステータス  : この質問を解決済みにする

認証コード  :
        キャプチャ画像


( 処理日時 : 2019-06-17 04:18:35 )

Page
Top