| |
▼ケメ子 さん：
こんにちは
もう少しまともなコードで記述します。
11/2/22(火) 0:44 にアップされたコードを踏まえています。
従来はaName=bNameでしたが、今回は異なる可能性もあるので、別途bNameを規定しましょう。
したがってbBookのOpenはbNmaeにて行うことにご留意ください。
（テストしてませんので不具合あればいってください）
追加
Dim bName As String
Dim myPre As String
コードの最初のほうで
myPre = ThisWorkbook.Sheets(1).Range("K5").Value
以下のように修正
For Each myFile In myFso.GetFolder(aPath).Files
aName = myFile.Name
If LCase(myFso.GetExtensionName(aName)) = "xls" Then
'aPathのaBook(aName) 12345ABC から cPathのcBook(cName) 【作業】12345 エービーシー を紐つける
cName = IsExists(cPath, aName, myPre)
If cName <> "" Then
Set cBook = Workbooks.Open(cPath & "\" & cName, UpdateLinks:=3) 'リンクの更新して開く
'------------------------------
'元ファイルから各シートへコピー
'------------------------------
Set aBook = Workbooks.Open(aPath & "\" & aName, Password:=ThisWorkbook.Sheets(1).Range("D7").Value) 'セルD7のパスワードで開く
'処理 省略
aBook.Close False
'----------------------------------------
'前月ファイルから各シートへランクデコード
'----------------------------------------
Set bBook = Nothing
'aNameから bPathのbBook(bName) 12345 ＡＢＣ を紐つける
bName = IsExists(bPath, aName, "")
If bName <> "" Then _
Set bBook = Workbooks.Open(bPath & "\" & bName, Password:=ThisWorkbook.Sheets(1).Range("D7").Value)
'処理 省略
'-------------------------------
'ブック処理完了 --> 次のブックへ
'-------------------------------
If Not bBook Is Nothing Then
bBook.Close False
cBook.Close True
End If
End If
End If
Next
さらに下記プロシジャを追加。
Private Function IsExists(myPath As String, myName As String, myPre As String) As String
Dim fName As String
Dim f1 As Long
Dim wk As String
f1 = Val(myName)
fName = Dir(myPath & "\" & myPre & f1 & "*.xls")
Do While fName <> ""
wk = Replace(fName, myPre, "", , 1) '頭の【作業】を除く
If f1 = Val(wk) Then
IsExists = fName
Exit Do
End If
fName = Dir()
Loop
End Function
|
|
UO3
- 11/3/5(土) 16:58 -
