I have a folder with .csv files but I am trying to import all the data from the files into one excel sheet. Also, I am trying to organize my data horizontally, and the it will only copy the variables once, and then just the data afterwards.
Sub ImportCSVsWithReferenceI()
'UpdatebyKutoolsforExcel20151214
'Dim xSht As Worksheet
Dim xSht As Workbook
Dim xWb As Workbook
Dim xStrPath As String
Dim xFileDialog As FileDialog
Dim xFile As String
Dim xCount As Long
On Error GoTo ErrHandler
With Application
.Calculation = xlCalculationManual
.EnableEvents = False
.ScreenUpdating = False
End With
Set xFileDialog = Application.FileDialog(msoFileDialogFolderPicker)
xFileDialog.AllowMultiSelect = False
xFileDialog.Title = "Select a folder [Kutools for Excel]"
If xFileDialog.Show = -1 Then
xStrPath = xFileDialog.SelectedItems(1)
End If
If xStrPath = "" Then Exit Sub
Set xSht = ThisWorkbook.ActiveSheet
If MsgBox("Clear the existing sheet before importing?", vbYesNo, "Kutools for Excel") = vbYes Then
xSht.UsedRange.Clear
xCount = 1
Else
xCount = xSht.Cells(3, Columns.Count).End(xlToLeft).Column + 1
End If
'Application.ScreenUpdating = False
xFile = Dir(xStrPath & "\" & "*.csv")
Do While xFile <> "" And xSht.Name
Set xWb = Workbooks.Open(xStrPath & "\" & xFile)
xWb.Sheets("Sheet1").Columns(2).Copy xSht.Sheets("").Cells(1, Columns.Count).End(xlToLeft).Offset(, 1)
'Rows(1).Insert xlShiftDown
'Range("B1") = ActiveSheet.Name
'ActiveSheet.UsedRange.Copy xSht.Cells(1, Columns.Count).End(xlToLeft).Offset(0, 1)
'ActiveSheet.Columns(2).Copy xSht.Cells(1, Columns.Count).End(xlToLeft).Offset(0, 1)
xWb.Close False
xFile = Dir
'xCount = xSht.Cells(3, Columns.Count).End(xlToLeft).Column + 1
Loop
Application.ScreenUpdating = True
Exit Sub
ErrHandler:
MsgBox "no files csv", , "Kutools for Excel"
End Sub
Code modified
xSht
declared as As Worksheet Sheets(1)
or ActiveSheet` Sheets("")
? deleted. Directly use xSht
as declared And xSht.Name
in Do while and deleted. Found working as far understood.
Sub ImportCSVsWithReferenceI()
'UpdatebyKutoolsforExcel20151214
Dim xSht As Worksheet
'Dim xSht As Workbook
Dim xWb As Workbook
Dim xStrPath As String
Dim xFileDialog As FileDialog
Dim xFile As String
Dim xCount As Long
Dim xOffset As Integer
' On Error GoTo ErrHandler
With Application
' .Calculation = xlCalculationManual
' .EnableEvents = False
' .ScreenUpdating = False
End With
Set xFileDialog = Application.FileDialog(msoFileDialogFolderPicker)
xFileDialog.AllowMultiSelect = False
xFileDialog.Title = "Select a folder [Kutools for Excel]"
If xFileDialog.Show = -1 Then
xStrPath = xFileDialog.SelectedItems(1)
End If
If xStrPath = "" Then Exit Sub
Set xSht = ThisWorkbook.ActiveSheet
If MsgBox("Clear the existing sheet before importing?", vbYesNo, "Kutools for Excel") = vbYes Then
xSht.UsedRange.Clear
End If
'Application.ScreenUpdating = False
xFile = Dir(xStrPath & "\" & "*.csv")
Do While xFile <> ""
Set xWb = Workbooks.Open(xStrPath & "\" & xFile)
xOffset = IIf(IsEmpty(xSht.Cells(1, Columns.Count).End(xlToLeft)), 0, 1)
xWb.Sheets(1).Columns(2).Copy xSht.Cells(1, Columns.Count).End(xlToLeft).Offset(, xOffset)
'Rows(1).Insert xlShiftDown
'Range("B1") = ActiveSheet.Name
'ActiveSheet.UsedRange.Copy xSht.Cells(1, Columns.Count).End(xlToLeft).Offset(0, 1)
'ActiveSheet.Columns(2).Copy xSht.Cells(1, Columns.Count).End(xlToLeft).Offset(0, 1)
xWb.Close False
xFile = Dir
Loop
Application.ScreenUpdating = True
End Sub
The technical post webpages of this site follow the CC BY-SA 4.0 protocol. If you need to reprint, please indicate the site URL or the original address.Any question please contact:yoyou2525@163.com.