teratail
回答率
85.47%
質問するログイン新規登録
トップに関する質問vbaでファイル移動

編集履歴

質問編集履歴

2

余分な空白を削除しました

2019/10/08 10:10

投稿

1008
1008

スコア5

test CHANGED
File without changes
test CHANGED
@@ -52,8 +52,6 @@
52
52
 
53
53
  Function 拡張子を取り除いたファイル移動() As FileSystemObject
54
54
 
55
-
56
-
57
55
  Dim myFileFullName As String
58
56
 
59
57
  Dim myFilePath As String
@@ -62,11 +60,11 @@
62
60
 
63
61
  Dim myFileNameCut As String
64
62
 
65
- Dim fso As New FileSystemObject
63
+ Dim fso As New FileSystemObject
66
64
 
67
65
  Dim f As file
68
66
 
69
- 　　'ファイル名はGetOpenFileNameメソッドで取得しています
67
+
70
68
 
71
69
  myFileFullName = ThisWorkbook.PATH & "*.psd"
72
70
 
@@ -77,12 +75,6 @@
77
75
 
78
76
 
79
77
  Do While myFileName <> ""
80
-
81
- 'ファイルがなくなるまで繰り返す
82
-
83
-
84
-
85
- '最後に「￥」つきのパス
86
78
 
87
79
  myFilePath = Left(myFileFullName _
88
80
 
@@ -108,35 +100,29 @@
108
100
 
109
101
  & vbCr & "拡張子を除いたファイル名：" & myFileNameCut
110
102
 
111
- '95ではvbCrに替えてChr(13)を使用
112
103
 
113
104
 
105
+ If Dir(myFileName) <> "" Then
114
106
 
115
- If Dir(myFileName) <> "" Then
116
-
117
- fso.MoveFile myFileFullName, ThisWorkbook.PATH & "\" & myFileNameCut
107
+ fso.MoveFile myFileFullName, ThisWorkbook.PATH & "\" & myFileNameCut
118
108
 
119
109
  Else: myFileFullName = myFilePath & "\" & myFileNameCut & ".psd"
120
110
 
121
- End If
111
+ End If
122
112
 
123
- For Each f In fso.MoveFile(myFileFullName, ThisWorkbook.PATH & "\" & myFileNameCut)
113
+ For Each f In fso.MoveFile(myFileFullName, ThisWorkbook.PATH & "\" & myFileNameCut)
124
114
 
125
- 　　 Next
115
+ 　　 Next
126
116
 
127
- 　 End If
117
+ 　 End If
128
118
 
129
- myFileName = Dir()
119
+ myFileName = Dir()
130
120
 
131
- Loop
121
+ Loop
132
122
 
133
- '後始末
123
+ Set fso = Nothing
134
124
 
135
- Set fso = Nothing
136
-
137
-
138
-
139
- End Function
125
+ End Function
140
126
 
141
127
  ```
142
128
 

1

※追記いたしました

2019/10/08 10:10

投稿

1008
1008

スコア5

test CHANGED
File without changes
test CHANGED
@@ -9,6 +9,28 @@
9
9
  VBAでファイル移動システムを作っています。
10
10
 
11
11
  ファイル名と移動先のフォルダ名が同じだった場合、それぞれ移動(複数)できる機能を実装中に以下のエラーメッセージが発生しました。
12
+
13
+ ※説明不足で申し訳ございません。追記させていただきます。
14
+
15
+ ・移動したいファイルはpsdデータです。
16
+
17
+
18
+
19
+ 資料1.psd　こちらを　資料1フォルダに格納させたいです。
20
+
21
+ 同様に
22
+
23
+ 資料2.psd　こちらを　資料2フォルダに格納
24
+
25
+ …　
26
+
27
+ こちらを繰り返します
28
+
29
+ 拡張子があると反応しなかったので、一度拡張子(.psd)を外した状態の名前を抽出して
30
+
31
+ そちらを使ってmove.File で移動できればと思いました。
32
+
33
+
12
34
 
13
35
 
14
36
 
@@ -78,8 +100,6 @@
78
100
 
79
101
 
80
102
 
81
-
82
-
83
103
  Debug.Print "選択されたファイル" & myFileFullName _
84
104
 
85
105
  & vbCr & "ファイル名：" & myFileName _
@@ -90,53 +110,25 @@
90
110
 
91
111
  '95ではvbCrに替えてChr(13)を使用
92
112
 
93
-
113
+
94
114
 
95
115
  If Dir(myFileName) <> "" Then
96
116
 
97
-
98
-
99
-
100
-
101
117
  fso.MoveFile myFileFullName, ThisWorkbook.PATH & "\" & myFileNameCut
102
-
103
-
104
-
105
-
106
118
 
107
119
  Else: myFileFullName = myFilePath & "\" & myFileNameCut & ".psd"
108
120
 
109
-
110
-
111
-
112
-
113
121
  End If
114
-
115
-
116
122
 
117
123
  For Each f In fso.MoveFile(myFileFullName, ThisWorkbook.PATH & "\" & myFileNameCut)
118
124
 
125
+ 　　 Next
119
126
 
127
+ 　 End If
120
128
 
121
- Next
122
-
123
-
124
-
125
- End If
126
-
127
-
128
-
129
- myFileName = Dir()
129
+ myFileName = Dir()
130
-
131
-
132
-
133
-
134
-
135
-
136
130
 
137
131
  Loop
138
-
139
-
140
132
 
141
133
  '後始末
142
134