英文:
Move/copy a file into 2+ destination folders if there is a delimitator in the filename
问题
抱歉，代码部分我将保持原文不翻译。
英文:
I want to expand this vba script that moves files from an inbox folder to the correct destination folder by using variables from the filename to lookup the correct investment folder path for the file in Sharepoint and then subsequently moves the file to the destination folder. Currently, the vba script only works on a 1:1 ratio though, moving 1 document into 1 destination folder. I need it to also be able to move 1 document into multiple destination folders if needed [or rather, move the document into the 1 destination folder then save copies of it to any others]. The trigger would be the existence of a special delimiter in the filename separating destinations. That said, it would also be helpful if the original filename was updated to include only the investment name for each copy saved. For Example -
Filename: 12901-01_Upside III_Carnegie;Carrington_CAS_2023.03.30.pdf
Action 1: Move original file into the Carnegie investment folder and rename: 12901-01_Upside III_Carnegie \_CAS_2023.03.30.pdf
Action 2: Save a copy of original file into the Carrington investment folder and rename: 12901-01_Upside III_Carrington_CAS_2023.03.30.pdf
There are few other nuances being considered in the full code, which you can see more pieces of in the screenshot below, but my main question is how to move a document multiple places if there is a delimitator in the filename. So, please keep in mind that I have only copied the sections of code below that I think are relevant to this question.
Public TaxPath_12900 As String
Public Investments As New collection
Public LogDataCol As New collection
Public LogDataBool As Boolean
Public ClientCode As String
Public ClientFolder As String
Public FieldCountAdj As Integer
Public ClientMapsFolder As String
Public ClientLogFolder As String
Public StopFlag As Boolean
Function CheckBoxFileExists(ByVal filePath As String) As Boolean
‘checks if file exists by searching for the filename in the folder and returns “true” or “false”
CheckBoxFileExists = False
Dim i As Integer
Dim fso As Object
Set fso = CreateObject("Scripting.fileSystemObject")
For i = 0 To 4 'wait for 5 seconds total if needed
If fso.FileExists(filePath) = False Then
Application.Wait (Now + TimeValue("0:00:01"))
Else
CheckBoxFileExists = True
Exit For
End If
Next i
End Function
Sub SetClientCodeVar()
Select Case ClientCode
Case "12900"
ClientFolder = " C:\Box\Client II\12901 Fund\Acct\Client Document Inbox\”
ClientMapsFolder = "C:\Box\Client II\12901 Fund\Acct\Client Maps\ "
ClientLogFolder = "C:\Box\Client II\12901 Fund\Acct\Client Log (SharePoint Upload)\"
FieldCountAdj = 1
TaxPath_12900 = " C:\Box\Client II\12901 Fund\Tax\Shared\tax docs\downloaded docs\”
End Select
End Sub
Function PopulateListBoxFromCSV(ListBox As MSForms.ListBox, clientName As String)
'needs "ms scripting runtime" and "Microsoft VBScript Regular Expressions 5.5"
ClientCode = Mid(clientName, 2, InStr(clientName, "]") - 2)
Call SetClientCodeVar
Dim filePath As String
filePath = ClientMapsFolder & ClientCode & "_MAP.CSV"
Dim fso As New FileSystemObject
Dim ts As TextStream
Dim row As Long
Dim arrData() As String
'open the file
Set ts = fso.OpenTextFile(filePath, ForReading)
UserForm1.Label_RefreshTime.Caption = "Mapping Refresh: " & FileDateTime(filePath)
'Open the file
'Open filePath For Input As #1
' Read the data from the file
Dim line As String
Dim rowString As String
Dim dupeRecords As Boolean
dupeRecords = False
Do While Not ts.AtEndOfStream
row = row + 1
rowString = ts.ReadLine
line = ReplaceCSVDelimiter(rowString)
arrData = Split(line, "|")
'populate collection
Dim investment As clsInvestmentList
Set investment = New clsInvestmentList
If ItemExists(arrData(0) & "-" & arrData(2), Investments) = False Then
investment.RowNum = row
investment.fundID = UCase(arrData(0))
investment.FundName = arrData(1)
investment.InvestmentID = UCase(arrData(2))
investment.InvestmentName = arrData(3)
investment.ProjectID = arrData(4)
investment.BaseFolderPath = arrData(5)
investment.StatementFolders = arrData(6)
investment.InvestActivityFolders = arrData(7)
Investments.Add investment, arrData(0) & "-" & arrData(2)
Else
dupeRecords = True
End If
Loop
Call PopulateListBox(ListBox)
ts.Close
If dupeRecords = True Then MsgBox ("Note: Your sharepoint list contains duplicate records for the same Fund ID & Investment ID pairing. Please remove duplicate records from sharepoint " & ClientCode & "_MAP.")
End Function
Function PopulateListBox(ListBox As MSForms.ListBox, Optional filterFundID As String = "")
Dim item As Variant
Dim i As Long
i = 0
For Each item In Investments
If filterFundID <> "" Then
If filterFundID <> item.fundID Then
GoTo NextIteration
End If
End If
' Add the data to the list box
ListBox.AddItem item.RowNum
ListBox.List(i, 1) = item.fundID
ListBox.List(i, 2) = item.FundName
ListBox.List(i, 3) = item.InvestmentID
ListBox.List(i, 4) = item.InvestmentName
ListBox.List(i, 5) = item.ProjectID
i = i + 1
NextIteration:
Next item
End Function
Sub ExportDiagnostics()
Dim wb As Workbook
Dim ws As Worksheet
Dim filePath As Variant
filePath = Application.GetSaveAsFilename("Folder Diagnostics " & ClientCode, fileFilter:="Excel Files (*.xlsx), *.xlsx", Title:="Select Destination Folder")
If filePath = False Then Exit Sub
Set wb = Workbooks.Add
Set ws = wb.Worksheets(1)
Dim i As Long
Dim UFLB As MSForms.ListBox
Set UFLB = UserForm2.ListBox1
For i = 0 To UFLB.ListCount - 1
ws.Cells(i + 1, 1).value = UFLB.List(i, 0)
ws.Cells(i + 1, 2).value = UFLB.List(i, 1)
ws.Cells(i + 1, 3).value = UFLB.List(i, 2)
ws.Cells(i + 1, 4).value = UFLB.List(i, 3)
ws.Cells(i + 1, 5).value = UFLB.List(i, 4)
ws.Cells(i + 1, 6).value = UFLB.List(i, 5)
ws.Cells(i + 1, 7).value = UFLB.List(i, 8)
ws.Cells(i + 1, 8).value = UFLB.List(i, 6)
ws.Cells(i + 1, 9).value = UFLB.List(i, 7)
Next i
Call ResizeSheet(ws)
wb.SaveAs filePath
wb.Close
MsgBox ("List exported to Excel.")
End Sub
Function CreateBrowserFormPath() As collection
Dim tempCollection As New collection
Dim str As String
Dim itemNo As Integer
Dim UF As UserForm
Set UF = UserForm1
itemNo = Int(UF.ListBox1.List(UF.ListBox1.ListIndex, 0))
str = Investments.item(itemNo).BaseFolderPath
If Right(str, 1) <> "\" Then str = str & "\"
tempCollection.Add str
Select Case UF.ComboBox1.Text
Case "FS & PCAPs"
str = str & Investments.item(Int(itemNo)).StatementFolders & "\"
If UF.ComboBox2.Text <> "" Then
str = str & UF.ComboBox2.Text & "\"
If UF.ComboBox3.Text <> "" Then str = str & UF.ComboBox3.Text & "\"
End If
Case "Investment Activity"
str = str & Investments.item(itemNo).InvestActivityFolders & "\"
End Select
tempCollection.Add str
Set CreateBrowserFormPath = tempCollection
End Function
Function GetFileMetaData(UFLB As MSForms.ListBox, Optional filterFundID As String = "")
Dim oFSO As Object
Dim oFolder As Object
Dim oFile As Object
Set oFSO = CreateObject("Scripting.FileSystemObject")
Set oFolder = oFSO.GetFolder(ClientFolder)
If CheckBoxFolderExists(ClientFolder) = False Then Exit Function
Dim fileNameArr() As String
Dim tempStr As String
Dim item As String
Dim sType As String
Dim i As Integer
Dim charCount As Integer
i = 0
For Each oFile In oFolder.Files
If LCase(Right(oFile.Name, 4)) <> ".pdf" Then GoTo NextIteration
fileNameArr = Split(Replace(LCase(oFile.Name), ".pdf", ""), "_")
If filterFundID <> "" Then
If filterFundID <> UCase(fileNameArr(0)) Then
GoTo NextIteration
End If
End If
charCount = Len(oFile.Name) - Len(Replace(oFile.Name, "_", ""))
If charCount <> 3 + FieldCountAdj Then GoTo NextIteration
UFLB.AddItem oFile.Name
' we want to use the investment ID variable below to retrieve Fund Name / Fund ID from our "investments" collection
UFLB.List(i, 1) = oFile.DateLastModified
If ItemExists(fileNameArr(0) & "-" & fileNameArr(1), Investments) = False Then
UFLB.List(i, 2) = ""
UFLB.List(i, 3) = ""
UFLB.List(i, 4) = ""
UFLB.List(i, 5) = ""
UFLB.List(i, 6) = ""
UFLB.List(i, 7) = ""
i = i + 1
GoTo NextIteration
End If
UFLB.List(i, 2) = UCase(fileNameArr(0))
UFLB.List(i, 3) = Investments.item(fileNameArr(0) & "-" & fileNameArr(1)).FundName
UFLB.List(i, 4) = UCase(fileNameArr(1))
UFLB.List(i, 5) = Investments.item(fileNameArr(0) & "-" & fileNameArr(1)).InvestmentName
Select Case UCase(fileNameArr(2 + FieldCountAdj))
Case "CAS"
sType = "Capital Account Statement"
Case "FS"
sType = "Financial Statements"
Case "CD"
sType = "Distribution"
Case "CC"
sType = "Contribution"
Case "K-1"
sType = "Tax"
End Select
UFLB.List(i, 6) = sType
UFLB.List(i, 7) = ConvertDateFormat(fileNameArr(3 + FieldCountAdj))
On Error GoTo 0
i = i + 1
NextIteration:
Next oFile
End Function
Function ItemExists(ByRef value As Variant, ByRef collection As collection) As Boolean
On Error Resume Next
ItemExists = False
ItemExists = Not (collection.item(value) Is Nothing)
On Error GoTo 0
End Function
Function CreateFormPath() As Collection
'function returns a collection object
Dim tempCollection As New Collection 'Declares a variable named "tempCollection" to hold a new instance of the Collection object
Dim strBase As String
Dim strDocType As String
Dim strYear As String
Dim strQtr As String 'Declares variables to hold different parts of the path
Dim itemKey As String 'Declares a variable named "itemKey" to hold a string
Dim UF As UserForm 'Declares a variable named "UF" to hold a reference to a UserForm
Set UF = UserForm3 'Assigns the reference of "UserForm3" to the "UF" variable
itemKey = UF.ListBox1.List(UF.ListBox1.ListIndex, 2) & "-" & UF.ListBox1.List(UF.ListBox1.ListIndex, 4)
'Constructs the "itemKey" by concatenating two values from ListBox1 on the UserForm
If ItemExists(itemKey, Investments) = False Then 'Checks if "itemKey" doesnt exist in the "Investments" collection
tempCollection.Add ""
tempCollection.Add ""
tempCollection.Add ""
tempCollection.Add "" 'Adds four empty strings to the "tempCollection"
Set CreateFormPath = tempCollection 'Sets the function's return value to the "tempCollection".
Exit Function
End If
strBase = Investments.Item(itemKey).BaseFolderPath 'Gets "BaseFolderPath" from "Investments" collection using the "itemKey"
Dim tempDates
tempDates = EndOfQuarter(CDate(UF.ListBox1.List(UF.ListBox1.ListIndex, 7)))
'Retrieves a date value from ListBox1 on the UserForm and calculates the end of the quarter using the "EndOfQuarter" function
If Right(strBase, 1) <> "\" Then strBase = strBase & "\" 'Checks if "strBase" doesn't end with a \ & adds one if needed
Select Case UF.ListBox1.List(UF.ListBox1.ListIndex, 6) 'begins case stmt based on value in UserForm ListBox1
Case "Capital Account Statement", "Financial Statements"'If ListBox1 value is "Capital Account Statement" or "Financial Statements", execute code block:
tempCollection.Add "CASFS" 'Adds "CASFS" to the "tempCollection"
strDocType = Investments.Item(itemKey).StatementFolders & "\"
'Appends the "StatementFolders" property from the "Investments" collection to "strDocType"
strYear = Left(tempDates, 4) & "\" 'Retrieves leftmost 4 characters of "tempDates" and appends a \ to "strYear"
strQtr = Right(tempDates, 2) & "\" 'Retrieves rightmost 2 characters of "tempDates" and appends a \ to "strQtr"
Case "Distribution", "Contribution" 'If ListBox1 value is "Distribution" or "Contribution", execute code block:
tempCollection.Add "CF" 'Adds "CF" to the "tempCollection"
strDocType = Investments.Item(itemKey).InvestActivityFolders & "\"
'Appends the "InvestActivityFolders" property from the "Investments" collection to "strDocType".
strYear = Left(tempDates, 4) & "\" 'Retrieves leftmost 4 characters of "tempDates" and appends a \ to "strYear"
strQtr = Right(tempDates, 2) & "\" 'Retrieves rightmost 2 characters of "tempDates" and appends a \ to "strQtr"
Case "Tax" 'If ListBox1's selected value is "Tax", the following code block is executed
tempCollection.Add "Tax" ' Adds "Tax" to the "tempCollection"
Select Case ClientCode 'Begins another Select Case statement based on the value of "ClientCode"
Case "12900" 'If "ClientCode" is "12900", the following code block is executed
strBase = TaxPath_12900 'Overrides the value of "strBase" with a predefined path
End Select
Case "" 'If ListBox1's selected value is empty, the following code block is executed
tempCollection.Add "" 'Adds an empty string to the "tempCollection"
End Select
tempCollection.Add strBase 'Adds year base to the "tempCollection"
tempCollection.Add strDocType 'Adds year doc type to the "tempCollection"
tempCollection.Add strYear 'Adds year string to the "tempCollection"
tempCollection.Add strQtr 'Adds quarter string to the "tempCollection"
Set CreateFormPath = tempCollection 'Sets the function's return value to the "tempCollection"
End Function
Function MoveClientFiles(SourceFileName As String, ByVal DestinFileName As String)
If Right(LCase(DestinFileName), 4) <> ".pdf" Then Exit Function
Dim fso As Object
Set fso = CreateObject("Scripting.Filesystemobject")
Dim i As Integer
Dim tempStr As String
Dim tempVer As String
tempStr = Left(DestinFileName, Len(DestinFileName) - 4)
tempVer = ""
i = 2
Do Until CheckBoxFileExists(tempStr & tempVer & ".pdf") = False
tempVer = "_V" & i
Loop
DestinFileName = tempStr & tempVer & ".pdf"
fso.MoveFile Source:=SourceFileName, Destination:=DestinFileName
Dim UFLB As MSForms.ListBox
Set UFLB = UserForm3.ListBox1
'populate collection
Dim logData As clsInvestmentList
Set logData = New clsInvestmentList
logData.LogTitle = UFLB.List(UFLB.ListIndex, 0)
logData.LogUserName = Application.UserName
logData.LogTimeStamp = Now()
logData.LogFundID = UFLB.List(UFLB.ListIndex, 2)
logData.LogFundName = UFLB.List(UFLB.ListIndex, 3)
logData.LogInvestmentID = UFLB.List(UFLB.ListIndex, 4)
logData.LogInvestmentName = UFLB.List(UFLB.ListIndex, 5)
logData.LogDestinationFolder = DestinFileName
logData.LogStatementType = UFLB.List(UFLB.ListIndex, 6)
logData.LogStatementDate = UFLB.List(UFLB.ListIndex, 7)
logData.LogFileDateModified = UFLB.List(UFLB.ListIndex, 1)
LogDataCol.Add logData
MsgBox ("File moved successfully! Details added to session log.")
UserForm3.ListBox1.RemoveItem UserForm3.ListBox1.ListIndex
End Function
答案1
得分: 1
以下是您代码示例的翻译部分：
您的代码示例非常长，因此我将为您提供一个示例，展示如何执行您的“主要问题”（即“如何在文件名中存在分隔符的情况下将文档移动到多个位置”），而不是重写您的代码。
以下代码已经注释，以解释每个部分的作用，然后您可以使用相关行更新您现有的代码（变量名称需要更改以匹配您的代码）。请注意，此代码（即此“Test”方法）是可运行的示例，因此如果您想查看它的工作原理，可以逐步执行代码：
Sub Test()
Dim text As String
text = "12901-01_Upside III_Carnegie;Carrington_CAS_2023.03.30.pdf"
' 将单个文本分割成以“;”分隔的文件名
Dim filenames As Variant
filenames = Split(text, ";") ' 假定分号仅用于分隔名称，不会出现在文件名中
' 迭代每个文件名...如果不存在“;”，则此循环只会执行1次，否则会执行多次
Dim index As Long, doingForFirstFile As Boolean
For index = LBound(filenames) To UBound(filenames)
' 我们是否正在处理第一个文件名？
doingForFirstFile = index = LBound(filenames)
If doingForFirstFile Then
Debug.Print Now, "第一个文件名是 '" & filenames(index) & "'"
' 在此处放置处理第一个文件的代码
Else
Debug.Print Now, "后续文件名是 '" & filenames(index) & "'"
' 在此处放置制作后续副本的代码...由于您正在使用FSO，所以可以使用其.CopyFile方法
End If
Next index
End Sub
有关如何使用FSO的.CopyFile方法，请参阅以下链接：
<details>
<summary>英文:</summary>
Your code sample is quite lengthy and so I am giving you an example of how your 'main question' (i.e. "how to move a document multiple places if there is a delimitator in the filename") could be done rather than re-writing your code.
The following code is commented to explain what each part does, you can then update your existing code with the relevant lines (the variable names will need to be changed to match your code). Note that the code (i.e. this `Test` method) is a runnable example so you can step through the code if you want to see how it works:
Sub Test()
Dim text As String
text = "12901-01_Upside III_Carnegie;Carrington_CAS_2023.03.30.pdf"
' split the single piece of text into file names delimited by ";"
Dim filenames As Variant
filenames = Split(text, ";") ' assumes semi-colon is only used to delimite names and can never appear within a file name
' iterate over each file name ... this loop can happen 1 time if no ";" is present, otherwise multiple times
Dim index As Long, doingForFirstFile As Boolean
For index = LBound(filenames) To UBound(filenames)
' are we working on the first file name?
doingForFirstFile = index = LBound(filenames)
If doingForFirstFile Then
Debug.Print Now, "The first file name is '" & filenames(index) & "'"
' put your code to process the first copy of the file here
Else
Debug.Print Now, "A subsequent file name is '" & filenames(index) & "'"
' put your code to make subsequent copies here ... as you are using FSO then you can use its .CopyFile method
End If
Next index
End Sub
For how to use the .CopyFile method of FSO, see [this link](https://learn.microsoft.com/en-us/office/vba/language/reference/user-interface-help/copyfile-method) and [this link](https://learn.microsoft.com/en-us/previous-versions/tn-archive/ee198744(v=technet.10))
</details>
通过集体智慧和协作来改善编程学习和解决问题的方式。致力于成为全球开发者共同参与的知识库，让每个人都能够通过互相帮助和分享经验来进步。
评论