我有一个csv文件,如下所示
当我选择所有单元格并将其手动复制/粘贴到另一个Excel文件中时,结果与原始结果相同。但是,尝试在VBA中执行相同操作会给我以下结果。
这是我正在使用的代码。
Sub test()
Dim arr1 As Object
Set arr1 = CreateObject("System.Collections.ArrayList")
Dim fldr As FileDialog
Dim sItem As String
Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
With fldr
.Title = "Select"
.AllowMultiSelect = False
.InitialFileName = strPath
If .Show <> -1 Then GoTo NextCode
sItem = .SelectedItems(1)
End With
NextCode:
GetFolder = sItem
'-----------------------------------------------------------
Dim FileName As Variant
FileName = Dir(GetFolder & "\")
'-----------------------------------------------------------
While FileName <> ""
arr1.Add GetFolder & "\" & FileName
FileName = Dir
Wend
'-----------------------------------------------------------
Set fldr = Nothing
Dim i As Long
For i = 0 To arr1.Count - 1
'-------------------------------------------------------------------
Dim wkbk As Workbook
Set wkbk = Workbooks.Open(arr1(i))
wb1 = wkbk.Name
Set sht = wkbk.Worksheets(wkbk.Sheets(1).Name)
wkbk.Sheets(sht.Name).Copy After:=ThisWorkbook.Sheets("START")
ActiveSheet.Name = "NEW"
' MsgBox wkbk.Name
' ThisWorkbook.Sheets.Add.Name = "NEW"
' wkbk.Sheets(sht.Name).Cells.Copy
' ThisWorkbook.Sheets("NEW").Cells.Paste
wkbk.Close False
Next i
End Sub
有没有办法获得与手动执行相同的结果?
Option Explicit
Sub importCSV()
Const InitialFolderPath As String = "F:\Test\2021"
Const FilePattern As String = "*.csv"
Dim dwb As Workbook: Set dwb = ThisWorkbook
Dim FolderPath As String
If Right(InitialFolderPath, 1) = "\" Then
FolderPath = InitialFolderPath
Else
FolderPath = InitialFolderPath & "\"
End If
Dim fd As FileDialog
Set fd = Application.FileDialog(msoFileDialogFolderPicker)
With fd
.Title = "Select"
.AllowMultiSelect = False
.InitialFileName = FolderPath
If .Show = False Then
MsgBox "You canceled."
Exit Sub
End If
FolderPath = .SelectedItems(1) & "\"
End With
Dim arl As Object: Set arl = CreateObject("System.Collections.ArrayList")
Dim FileName As String: FileName = Dir(FolderPath & FilePattern)
Do While FileName <> ""
arl.Add FolderPath & FileName
FileName = Dir
Loop
Application.ScreenUpdating = False
Dim swb As Workbook
Dim sws As Worksheet
Dim dws As Worksheet
Dim shId As Long
Dim i As Long
For i = 0 To arl.Count - 1
Set swb = Workbooks.Open(FileName:=arl(i), Local:=True)
Set sws = swb.Worksheets(1)
sws.Copy After:=dwb.Sheets(dwb.Sheets.Count)
Set dws = ActiveSheet
shId = shId + 1
On Error GoTo NewSheetError
dws.Name = "New" & shId
On Error GoTo 0
swb.Close False
Next i
'dwb.Save
Application.ScreenUpdating = True
Exit Sub
NewSheetError:
shId = shId + 1
Resume
End Sub
本文收集自互联网,转载请注明来源。
如有侵权,请联系[email protected] 删除。
我来说两句