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

デスクトップのファイル

投稿者 : ゆうきや     投稿日時 : 2017/04/25(Tue) 13:13:38     OS : 未指定     EXCEL : 未指定
初めましてです。
よろしくお願いします。

現在、デスクトップにダウンロードされたdatファイルをcsvにリネームしてセーブする
VBAを作成しています。(下記参照)

-----------------------------------------------------------------------
Const OLD_EXTENSION As String = "test.dat"
Const NEW_EXTENSION As String = "test.csv"

Const SAVE_DIR As String = "C:UserssaitouDesktop" ← ①
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
-----------------------------------------------------------------------

上記でリネームしてcsvに保存することはできるのですが、
作業をする人が違う場合(デスクトップが違う)に「①」を都度、その人のデスクトップに
修正しなければなりません。

【質問】
誰のデスクトップ上でも、問題なくできるようにできますでしょうか?

ご教授、よろしくお願いします。

[返信 1] Re : デスクトップのファイル
投稿者 : イトウ     投稿日時 : 2017/04/25(Tue) 16:22:10
Const SAVE_DIR As String = "C:UserssaitouDesktop" ← ①

ログインユーザーのデスクトップであれば
上記部分を以下のように書き換えればいけると思いますよ。


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

[返信 2] Re : デスクトップのファイル
投稿者 : ゆうきや     投稿日時 : 2017/04/26(Wed) 09:41:04
イトウ様

早速のご回答、ありがとうございます。

予想外のことが。。。

上記、作業後に以下のような処理がありました

----------------------------------------------------------------

With ActiveSheet.QueryTables.Add(Connection:= _
"TEXT;C:UserssatouDesktop est.csv", Destination:=Range("$A$2"))
.Name = "text"
.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

-------------------------------------------------------------------------

置き換えたCSVファイルを取り込んでいると思われるのですが、

最後の
> .Refresh BackgroundQuery:=False にて
「外部データ範囲を更新するためのテキストファイルが見つかりません。
テキストファイルが移動または名前が変更されていないことを確認し、再度実行
してください」とのメッセージが表示されました

With ActiveSheet.QueryTables.Add(Connection:= _
"TEXT;C:UserssatouDesktop est.csv", Destination:=Range("$A$2"))
.Name = "text"

このあたりが原因なのでしょうか?

[返信 3] Re : デスクトップのファイル
投稿者 : イトウ     投稿日時 : 2017/04/26(Wed) 12:48:37
前に回答したとおり変数にデスクトップのパスを格納してあるので、
ハードコーディングしてあるCSVのパスをその変数に置き換えればいいと思います。

●修正前
> With ActiveSheet.QueryTables.Add(Connection:= _
> "TEXT;C:UserssatouDesktop est.csv", Destination:=Range("$A$2"))

●修正後
With ActiveSheet.QueryTables.Add(Connection:= _
"TEXT;" & SAVE_DIR & "est.csv", Destination:=Range("$A$2"))

[返信 4] Re : デスクトップのファイル
投稿者 : ゆうきや     投稿日時 : 2017/04/27(Thu) 09:40:18
イトウ様
ご返信、ありがとうございます。

ご指摘いただいた箇所を修正したのですが、やはりエラーが出てしまいました。

> .Refresh BackgroundQuery:=False にて
「外部データ範囲を更新するためのテキストファイルが見つかりません。
テキストファイルが移動または名前が変更されていないことを確認し、再度実行
してください」とのメッセージが表示されました

以下にステートメントをコピーしておきます

-------------------------------------------------------------------------
Sub test_import()
'
' test_import Macro
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

Const OLD_EXTENSION As String = "test.dat"
Const NEW_EXTENSION As String = "test.csv"

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

With ActiveSheet.QueryTables.Add(Connection:= _
"TEXT;" & SAVE_DIR & "test.csv", Destination:=Range("$A$2"))

.Name = "test"
.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

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")

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

naisen_LastRow = Worksheets("内線マスタ").Cells(Rows.Count, 1).End(xlUp).Row

work_LastRow = Worksheets("work").Cells(Rows.Count, 1).End(xlUp).Row

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

Range(Range("B1"), Cells(Rows.Count, 2).End(xlUp)).Copy

Sheets("明細").Select

Range("E2").Select
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

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


-------------------------------------------------------------------------

[返信 5] Re : デスクトップのファイル
投稿者 : ゆうきや     投稿日時 : 2017/05/10(Wed) 09:30:42
回答いただいた方に再度質問をしたのですが、
なかなか回答を得られないため、一旦クローズさせて頂き
再度、質問をさせて頂きます。

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

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


( 処理日時 : 2019-08-26 09:56:54 )

Page
Top