Question

好的，所以我无法尝试打开一个名为＆＃34; testymctesttest_0001a.csv＆＃34;的文件。然后重命名，然后使用名称＆＃34; 001a＆＃34;保存相同的文件。到另一个文件夹。我试图在给定文件夹中的大约700个文件上执行此操作。有些人在号码末尾有一封信（例如，0001a），有些人没有这封信（ex 0218）。有没有办法这样做而不将所有csv数据复制到工作簿只是为了将该工作簿保存为另一个CSV？我尝试了下面的代码，除了所有新保存的CSV数据都在新文件夹中损坏外，一切正常。

Sub openSavefile()

Dim filePaths() As String
Dim lineFromFile As String
Dim lineItems() As String
Dim rowNum As Long
Dim actWkb As Workbook
Dim ary() As String
Dim ary2() As String
Dim fPath As String
Dim i As Long
Dim j As Long

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

Line1:
filePaths = selectFilesFunc

If filePaths(1) = "0" Then
   Exit Sub
End If
If filePaths(1) = "-1" Then
   GoTo Line1
End If

For j = 1 To UBound(filePaths)

Workbooks.Add
Set actWkb = ActiveWorkbook
Cells(1, 1).Activate
rowNum = 0

ary = Split(filePaths(j), "\")
ary2 = Split(ary(UBound(ary)), "_")
ary = Split(ary2(UBound(ary2)), ".")

Cells(1, 10).Value = ary(0)
fPath = "H:\TEST\FR2\"

Open filePaths(j) For Input As #1
Do Until EOF(1)
    Line Input #1, lineFromFile
    lineItems = Split(lineFromFile, ",")
    If UBound(lineItems) < 4 Then
        For i = 0 To UBound(lineItems)
            ActiveCell.Offset(rowNum, i).Value = lineItems(i)
        Next i
    Else
        If lineItems(7) = "HEX" Then
            Range("D" & rowNum + 1 & ":G" & rowNum + 1).NumberFormat = "@"
            'Range("D" & rowNum + 1 & ":G" & rowNum + 1).HorizontalAlignment = xlRight
        End If

        For i = 0 To UBound(lineItems)
            ActiveCell.Offset(rowNum, i).Value = lineItems(i)
        Next i
    End If
    rowNum = rowNum + 1
Loop
actWkb.SaveAs fPath & ary(0) & ".csv"
actWkb.Close
Close #1
Next j

Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic

End Sub

函数selectFilesFunc只获取要打开的文件路径数组。并且数组索引ary（0）只保存要保存为的新文件名（ex 0001a或0218）。

我搜索了很多地方找到了答案，我觉得这是一个我失踪的简单命令。但我的最终目标只是使用Open filePaths打开CSV（对于输入为＃1或类似的东西），只需使用新名称和文件路径保存该文件。但是，如果我必须将其导入工作簿然后另存为CSV，那么我想知道如何在不破坏数据的情况下执行此操作。

感谢您的帮助！

Answer 1

无需打开文件即可执行此操作它只是将文件重命名为最后一个下划线后的文本，并将文件从sSourceFolder移动到sDestinationFolder：

Public Sub RenameAndMove()

    Dim colFiles As Collection
    Dim vFile As Variant
    Dim sFileName As String
    Dim oFSO As Object
    Dim sSourceFolder As String
    Dim sDestinationFolder As String

    Set colFiles = New Collection
    sSourceFolder = "S:\DB_Development_DBC\Test\"
    sDestinationFolder = "S:\DB_Development_DBC\Test1\"

    EnumerateFiles sSourceFolder, "*.csv", colFiles

    Set oFSO = CreateObject("Scripting.FileSystemObject")
    For Each vFile In colFiles
        'Get the new filename.
        sFileName = Mid(vFile, InStrRev(vFile, "_") + 1, Len(vFile))
        On Error Resume Next
            'Move the file.
            oFSO.movefile vFile, sDestinationFolder & sFileName
            'You can delete this row if you want.
            'It states whether the move was successful in the Immediate window.
            Debug.Print vFile & " = " & (Err.Number = 0)
        Err.Clear
    Next vFile

End Sub

Sub EnumerateFiles(ByVal sDirectory As String, _
    ByVal sFileSpec As String, _
    ByRef cCollection As Collection)

    Dim sTemp As String

    sTemp = Dir$(sDirectory & sFileSpec)
    Do While Len(sTemp) > 0
        cCollection.Add sDirectory & sTemp
        sTemp = Dir$
    Loop

End Sub

打开CSV文件并使用不同的名称和文件路径保存相同的CSV

1 个答案: