the below code is working perfectly but when i added the "'" code the code will stop after n number of loop related for each (rng1) giving an error of overflow run-time error 6
Appreciate if you can help me and if there is any possibility to optimize the code, thank you
the below code is working perfectly but when i added the "'" code the code will stop after n number of loop related for each (rng1) giving an error of overflow run-time error 6
Appreciate if you can help me and if there is any possibility to optimize the code, thank you
Sub Count()
Dim myPath As String
Dim myFile As String
Dim FldrPicker As FileDialog
Dim sh As Worksheet
Dim i As Integer
Dim j As Integer
Dim Count As Integer
Dim CountRecords As String
Dim FilePath As String
Dim UniquePercentage As Integer
Dim SumOfUniqueness As Integer
Dim CountOfUniqueness As Integer
Dim rng As Range
Dim rng1 As Range
Dim LastPosition As Integer
Set sh = ThisWorkbook.Sheets(1)
Set FldrPicker = Application.FileDialog(msoFileDialogFolderPicker)
With FldrPicker
.Title = "Please Select Folder"
.AllowMultiSelect = False
.ButtonName = "Confirm"
If .Show = -1 Then
myPath = .SelectedItems(1) & "\"
Else
End
End If
End With
sh.Cells.ClearContents
myFile = Dir(myPath)
i = 1
Do While myFile <> ""
sh.Cells(1, 1) = "Table Name"
sh.Cells(i + 1, 1) = myFile
sh.Cells(1, 2) = "Count of records"
sh.Cells(1, 3) = "Uniqueness"
Count = Count + 1
myFile = Dir
i = i + 1
Loop
j = 1
For i = 1 To Count
sh.Activate
Worksheets(1).Activate
FilePath = myPath & Range("A" & j + 1).Value
Workbooks.Open FilePath
Worksheets("Properties").Activate
CountRecords = Sheets("Properties").Range("C15").Value
Worksheets("Column Profile").Activate
LastPosition = Range("D10").End(xlDown).Row - 2
For Each rng In Range("D10:D" & LastPosition)
rng.Value = Replace(rng, "-", "0")
rng.Value = CInt(rng)
Next rng
'For Each rng1 In Range("E10:E" & LastPosition)
'rng1.Value = Replace(rng1, "-", "0")
'rng1.Value = CInt(rng1)
'Next rng1
CountOfUniqueness = WorksheetFunction.CountIf(Range("E10:E" & LastPosition), 0)
SumOfUniqueness = WorksheetFunction.Sum(Range("D10:D" & LastPosition))
UniquePercentage = SumOfUniqueness / CountOfUniqueness
ActiveWorkbook.Close (False)
sh.Activate
Worksheets(1).Activate
Range("B" & j + 1).Value = CountRecords
Range("C" & j + 1).Value = UniquePercentage
j = j + 1
Next i
If i = 1 Then
MsgBox("There are no items in this folder:" & Dir(myPath))
End If
End Sub
Related
I'm trying to name sheets based on the current date. I need a counter variable to name sheets so they're unique.
I made two attempts:
Sub COPIAR_MODELO()
Application.ScreenUpdating = False
Dim i As Integer, x As Integer
Dim shtname As String
Dim WSDummy As Worksheet
Dim TxtError As String
Dim counter As Long
counter = 0
Name01:
For counter = 1 To 100 Step 0
TxtError = ""
counter = counter + 1
shtname = Format(Now(), "dd mm yyyy") & " - " & counter
On Error Resume Next
Set WSDummy = Sheets(shtname)
If Not (WSDummy Is Nothing) Then TxtError = "Name taken, additional sheet added!"
Next counter
If TxtError <> "" Then MsgBox "" & TxtError: GoTo Name01
Sheets("MODELO - NFS").Copy Before:=Sheets("MODELO - DEMAIS"): ActiveSheet.Name = shtname
Application.ScreenUpdating = True
End Sub
Expected result:
And:
Sub COPIAR_MODELO()
Application.ScreenUpdating = False
Dim i As Integer, x As Integer
Dim shtname As String
Dim WSDummy As Worksheet
Dim TxtError As String
Dim counter As Long
TxtError = ""
shtname = Format(Now(), "dd mm yyyy")
On Error Resume Next
Set WSDummy = Sheets(shtname)
If Not (WSDummy Is Nothing) Then TxtError = "Name taken, additional sheet added!"
If TxtError <> "" Then MsgBox "" & TxtError: GoTo Name01
If TxtError = "" Then GoTo NameOK
Name01:
For counter = 1 To 100 Step 1
counter = counter + 1
shtname = Format(Now(), "dd mm yyyy") & " - " & counter
Next counter
NameOK:
Sheets("MODELO - NFS").Copy Before:=Sheets("MODELO - DEMAIS"): ActiveSheet.Name = shtname
Application.ScreenUpdating = True
End Sub
Expected result:
I will assign this code to a shape to create the sheets based on the current date.
I prefer result 2.
Copy Template
Sub CopyTemplate()
Const PROC_TITLE As String = "Copy Template"
Const TEMPLATE_WORKSHEET_NAME As String = "MODELO - NFS"
Const BEFORE_WORKSHEET_NAME As String = "MODELO - DEMAIS"
Const DATE_FORMAT As String = "dd mm yyyy"
Const DATE_NUMBER_DELIMITER As String = " - "
Const FIRST_NUMBER As Long = 2
Const FIRST_WORKSHEET_HAS_NUMBER As Boolean = False
Const INPUT_BOX_PROMPT As String = "Input number of worksheets to create."
Const INPUT_BOX_DEFAULT As String = "1"
Dim WorksheetsCount As String: WorksheetsCount _
= InputBox(INPUT_BOX_PROMPT, PROC_TITLE, INPUT_BOX_DEFAULT)
If Len(WorksheetsCount) = 0 Then Exit Sub
Dim DateName As String: DateName = Format(Date, DATE_FORMAT)
Dim NewName As String: NewName = DateName
Dim NewNumber As Long: NewNumber = FIRST_NUMBER
If FIRST_WORKSHEET_HAS_NUMBER Then
NewName = NewName & DATE_NUMBER_DELIMITER & NewNumber
NewNumber = NewNumber + 1
End If
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
Dim wsTemplate As Worksheet
Set wsTemplate = wb.Worksheets(TEMPLATE_WORKSHEET_NAME)
Dim wsBefore As Worksheet
Set wsBefore = wb.Worksheets(BEFORE_WORKSHEET_NAME)
Dim wsNew As Worksheet
Dim WorksheetNumber As Long
Application.ScreenUpdating = False
Do While WorksheetNumber < WorksheetsCount
On Error Resume Next
Set wsNew = wb.Worksheets(NewName)
On Error GoTo 0
If wsNew Is Nothing Then
wsTemplate.Copy Before:=wsBefore
wsBefore.Previous.Name = NewName
WorksheetNumber = WorksheetNumber + 1
Else
NewName = DateName & DATE_NUMBER_DELIMITER & NewNumber
NewNumber = NewNumber + 1
Set wsNew = Nothing
End If
Loop
Application.ScreenUpdating = True
MsgBox WorksheetsCount & " worksheet" & IIf(WorksheetsCount = 1, "", "s") _
& " created.", vbInformation, PROC_TITLE
End Sub
If you overplay it...
Sub DeleteCreatedWorksheets()
Const PROC_TITLE As String = "Delete Created Worksheets"
Const BEFORE_WORKSHEET_NAME As String = "MODELO - DEMAIS"
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
Dim wsBefore As Worksheet
Set wsBefore = wb.Worksheets(BEFORE_WORKSHEET_NAME)
Dim wsIndex As Long: wsIndex = wsBefore.Index - 1
If wsIndex > 0 Then
Application.DisplayAlerts = False
Dim n As Long
For n = wsIndex To 1 Step -1
wb.Worksheets(n).Delete
Next n
Application.DisplayAlerts = True
End If
MsgBox wsIndex & " created worksheet" _
& IIf(wsIndex = 1, "", "s") & " deleted.", _
vbInformation, PROC_TITLE
End Sub
Hello everyone yesterday ı try to do Save Excel Row Via Vba Loop, now my problem is give hyplinks that file via macro.
I try to explain in photo and my codes are below
Sub Hyperlinks()
Dim wks As Worksheet
Dim hl As Hyperlink
Const RootPath As String = "X:\EVEREST-2\EVEREST ERP\ÜRETİM\PDM SOLID DOSYA YOLU\"
Const SeriCol As Long = 3
Const NameCol As Long = 4
Const YearCol As Long = 24
Set wks = ActiveSheet
Dim r As Long: r = FirstRow
Dim FileBaseName As String: FileBaseName = ws.Cells(r, SeriCol)
Dim hl_name As String: hl_name = ws.Cells(r, NameCol)
Dim year As String: year = ws.Cells(r, YearCol)
Do Until Len(hl_name) = 0
wks.Hyperlinks.Add ws.Cells(r, NameCol), Address:=(RootPath & year & "\" & FileBaseName & ".bat"TextToDisplay:=hl_name)
r = r + 1
Loop
MsgBox "Hyperlinks created.", vbInformation End sub
Create Hyperlinks
' *** You want to reference the model cell before and at the end of the loop.
A Quick Fix
Option Explicit
Sub CreateHyperlinks()
Const RootPath As String = "X:\EVEREST-2\EVEREST ERP\ÜRETIM\PDM SOLID DOSYA YOLU\"
Const YearCol As String = "X"
Const SerialCol As String = "C"
Const ModelCol As String = "D"
Const FirstRow As Long = 2
Dim wks As Worksheet: Set wks = ActiveSheet ' improve!
Dim r As Long: r = FirstRow
Dim ModelCell As Range: Set ModelCell = wks.Cells(r, ModelCol) ' ***
Dim FilePath As String
Dim YearPath As String
Dim Serial As String
Do Until Len(CStr(ModelCell.Value)) = 0
YearPath = CStr(wks.Cells(r, YearCol)) & "\"
Serial = CStr(wks.Cells(r, SerialCol))
FilePath = RootPath & YearPath & Serial & ".bat"
wks.Hyperlinks.Add Anchor:=ModelCell, Address:=FilePath
r = r + 1
Set ModelCell = wks.Cells(r, ModelCol) ' ***
Loop
MsgBox "Hyperlinks created.", vbInformation
End Sub
There is a comma missing between ".bat" and TextToDisplay:
Address:=(RootPath & year & "\" & FileBaseName & ".bat"TextToDisplay:=hl_name)
Note: There is no need to use the TextToDisplay parameter when the display text is the same as the anchor cell value.
Refactored Code
Sub Hyperlinks()
Dim wks As Worksheet
Dim hl As Hyperlink
Const RootPath As String = "X:\EVEREST-2\EVEREST ERP\ÜRETIM\PDM SOLID DOSYA YOLU\"
Const SeriCol As Long = 3
Const NameCol As Long = 4
Const YearCol As Long = 24
Set wks = ActiveSheet
Dim r As Long: r = FirstRow
Dim FileBaseName As String: FileBaseName = ws.Cells(r, SeriCol)
Dim year As String: year = ws.Cells(r, YearCol)
Dim Address As String
Do Until Len(hl_name) = 0
Address = RootPath & year & "\" & FileBaseName & ".bat"
wks.Hyperlinks.Add ws.Cells(r, NameCol), Address:=Address
r = r + 1
Loop
MsgBox "Hyperlinks Added"
End Sub
ı fix it now it works
Sub Hyperlinks1()
Dim hl As Hyperlink
Const RootPath As String = "X:\EVEREST-2\EVEREST ERP\ÜRETİM\PDM SOLID DOSYA YOLU\"
Const SeriCol As Long = 3
Const NameCol As Long = 4
Const YearCol As Long = 24
Dim ws As Worksheet: Set ws = ActiveSheet
Dim r As Long: r = 4
Dim FileBaseName As String: FileBaseName = ws.Cells(r, SeriCol)
Dim hl_name As String: hl_name = ws.Cells(r, NameCol)
Dim year As String: year = ws.Cells(r, YearCol)
year = Right(year, 4)
Do Until Len(hl_name) = 0
With ws
.Hyperlinks.Add Anchor:=.Cells(r, NameCol), _
Address:=RootPath & year & "\" & FileBaseName & ".bat", _
ScreenTip:="Click to open 3D Solid File", _
TextToDisplay:=hl_name
End With
r = r + 1
FileBaseName = ws.Cells(r, SeriCol)
hl_name = ws.Cells(r, NameCol)
year = ws.Cells(r, YearCol)
year = Right(year, 4)
Loop
MsgBox "Hyperlinks created.", vbInformation
End Sub
I just started working with VBA.
I have a VBA code that counts the number of the occurence of words inside the excel file. It works fine.
I want to run this VBA macro on all files I have inside a specific folder.
Could you help me out?
My code below:
I am getting values right only for the file from which I ran the macro. For the rest of the files, the reults obtained are wrong
Sub LoopThroughFiles()
Dim xFd As FileDialog
Dim xFdItem As Variant
Dim xFileName As String
Set xFd = Application.FileDialog(msoFileDialogFolderPicker)
If xFd.Show = -1 Then
xFdItem = xFd.SelectedItems(1) & Application.PathSeparator
xFileName = Dir(xFdItem & "*.xls*")
Do While xFileName <> ""
With Workbooks.Open(xFdItem & xFileName)
Dim wordList As New Collection
Dim keyList As New Collection
Dim c
Worksheets("Sheet1").Activate
Dim RangeToCheck As Range
Set RangeToCheck = Range("A1:A1000")
For Each c In RangeToCheck
Dim words As Variant
words = Split(c, " ")
For Each w In words
Dim temp
temp = -1
On Error Resume Next
temp = wordList(w)
On Error GoTo 0
If temp = -1 Then
wordList.Add 1, Key:=w
keyList.Add w, Key:=w
Else
wordList.Remove (w)
keyList.Remove (w)
wordList.Add temp + 1, w
keyList.Add w, Key:=w
End If
Next w
Next c
Dim x
Dim k
k = 1
For x = 1 To wordList.Count
With Sheets("Sheet1")
.Cells(k, "E").Value = keyList(x)
.Cells(k, "F").Value = wordList(x)
k = k + 1
End If
End With
Next x
End With
xFileName = Dir
Loop
End If
End Sub
Try this
Public Sub LoopThroughFiles()
Dim xFd As FileDialog
Set xFd = Application.FileDialog(msoFileDialogFolderPicker)
xFd.AllowMultiSelect = False
If xFd.Show <> -1 Then
MsgBox "No Folder selected": Exit Sub
End If
Dim Folder As String: Folder = xFd.SelectedItems(1) & "\"
Dim Files
Files = Dir(Folder & "*.xls*")
Dim Xls As String
On Error Resume Next
Dim CrWB As Workbook, CrSheet As Worksheet
Dim ClnW As New Collection, ClnC As New Collection
Dim Cols As Integer: Cols = 1
Do While Files <> ""
Xls = Replace(Folder & Files, "\\", "\")
Set CrWB = Application.Workbooks.Open(Xls, , True)
Set CrSheet = CrWB.Sheets("Sheet1")
If Err.Number > 0 Then
MsgBox "Can't open File " & Xls & vbCrLf & Err.Description
Err.Clear
GoTo 1
End If
Dim c As Range
Set ClnW = New Collection: Set ClnC = New Collection
For Each c In CrSheet.Range("A1:A1000")
If c.Value <> "" Then
Words = Split(CStr(c.Value), " ", , vbTextCompare)
For Each s In Words
Err.Clear
tmp = ClnW(s)
If Err.Number > 0 Then
ClnW.Add Item:=s, Key:=s
ClnC.Add Item:=1, Key:=s
Else
x = ClnC(s) + 1
ClnC.Remove s
ClnC.Add Item:=x, Key:=s
End If
Next
End If
Next
Set CrSheet = ThisWorkbook.Sheets("Sheet1")
With CrSheet
.Cells(1, Cols).Value = Files
.Cells(2, Cols).Value = "Word"
.Cells(2, Cols + 1).Value = "Occurance"
.Range(.Cells(1, Cols), .Cells(1, Cols + 1)).Merge
Dim I As Integer: I = 3
For Each s In ClnW
.Cells(I, Cols).Value = s
.Cells(I, Cols + 1).Value = ClnC(s)
I = I + 1
Next
End With
Cols = Cols + 2
1
CrWB.Close False
Files = Dir()
Err.Clear
Loop
End Sub
I have an inventory list for tools. The point of this program is to search for tools based on tool number entered and based on tool information to locate the corresponding tool file in the specific folder. The name of the files contain part of the tool information.
I loop through the inventory list first, once locating a specific tool, retriving corresponding information and trying to match with the file names within the folder. Here I created another loop to go through the files.
Sub openBaseline(tn)
Dim objFSO As Object
Dim objFolder As Object
Dim objFile As Object
Dim intpath As String
Dim path As String
Dim pn As String
Dim ps As String
Dim varr()
Dim partnum As String
Dim toolsize As String
Dim toolnumber As String
Dim i As Integer
'Testing If Me.idBox.Value = "" And Me.beadBox.Value = "" And Me.partBox.Value = "" Then Exit Sub
If tn = "" Then tn = InputBox("Scan or enter tool number.", "Load Baseline", "")
If tn = "" Then Exit Sub
'If Right(Left(tn, 2), 1) <> "-" Then
'If Len(tn) = 5 Then
'tn = Left(tn, 1) & "-" & Right(tn, 4)
'Else:
'MsgBox "Tool numbers should be in the format of '1-1234'", vbOKOnly + vbExclamation, "Error"
'Exit Sub
'End If
'End If
toolnumber = tn
'Debug.Print toolnumber
With ThisWorkbook.Sheets("Tool Log")
intpath = "H:\PROCESS\PROCESS SAMPLES\SI-Baselines\JSP" 'Switch to \woodbridge.corp etc
Set objFSO = CreateObject("Scripting.Filesystemobject")
Set objFolder = objFSO.getfolder(intpath)
'For Each objFile In objFolder.Files
'varr = Split(objFile.Name, " ")
'ReDim Preserve filename(objFolder.Files.count, 2)
For i = 2 To .Cells(Rows.count, 1).End(xlUp).row Step 1
'Debug.Print .Cells(Rows.count, 1).End(xlUp).row
Debug.Print .Cells(i, "A")
If .Cells(i, 1).Text = toolnumber Then
Debug.Print i
pn = .Cells(i, 3).Value
ps = .Cells(i, 4).Value
Debug.Print pn
Debug.Print ps
End If
'i = 1
For Each objFile In objFolder.Files
Debug.Print objFile.Name
'Debug.Print objFile.path
varr() = Split(objFile.Name, " ")
partnum = varr(0)
toolsize = varr(1)
Debug.Print partnum
Debug.Print toolsize
path = objFile.Name
'Does not work for family tools
Select Case toolsize
Case Is = ps
If partnum = pn Then
Workbooks.Open filename:=objFile.path, UpdateLinks:=False, ReadOnly:=True
Exit For
End If
Case Is = Right(varr(1), Len(varr(1)) - 1)
If partnum = pn Then
Workbooks.Open filename:=objFile.path, UpdateLinks:=False, ReadOnly:=True
Exit For
End If
End Select
Next objFile
'And toolsize = Right(ps, Len(ps) - 1) Then
'path = objFile.Name
'path = Right(path, Len(path) - Len(pn) - 1)
'If Left(path, Len(ps)) = ps Then
'Workbooks.Open filename:=objFile.path, UpdateLinks:=False, ReadOnly:=True
'Exit For
'End If
'End If
'i = i + 1
Next i
End With
End Sub
It gives a Type mismatch error on line
varr() = Split(objFile.Name, " ")
Declare you array variable as array of String (preferable) or as a single Variant, but not as an array of Variant
Also, you should omit the brackets when assigning the result of the split-command.
Dim varr() as String
' or: Dim varr as Variant
...
varr = Split(objFile.Name, " ")
Who can help with this macro?
It's merging csv files into one.
csv files can be more than 500 and its running slow.
By the way it's taiking all data in csv file (2 rows). it will work for me if macro can take just second row from file..
Any ideas?
Option Explicit
Sub ImportCSV65()
Dim strSourcePath As String
Dim strDestPath As String
Dim strFile As String
Dim strData As String
Dim x As Variant
Dim Cnt As Long
Dim r As Long
Dim c As Long
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
'Change the path to the source folder accordingly
strSourcePath = Worksheets("Tarpinis").Range("AJ8").Value
If Right(strSourcePath, 1) <> "\" Then strSourcePath = strSourcePath & "\"
strFile = Dir(strSourcePath & "*.csv")
Sheets("+65").Select
Application.ScreenUpdating = False
Do While Len(strFile) > 0
Cnt = Cnt + 1
If Cnt = 1 Then
r = 1
Else
r = Cells(Rows.Count, "A").End(xlUp).Row + 1
End If
Open strSourcePath & strFile For Input As #1
If Cnt > 1 Then
Line Input #1, strData
End If
Do Until EOF(1)
Line Input #1, strData
x = Split(strData, ",")
For c = 0 To UBound(x)
Cells(r, c + 1).Value = Trim(x(c))
Next c
r = r + 1
Loop
Close #1
Name strSourcePath & strFile As strSourcePath & strFile
strFile = Dir
Loop
Application.ScreenUpdating = True
If Cnt = 0 Then _
MsgBox "No CSV files were found...", vbExclamation
Application.ScreenUpdating = False
End Sub
How about the following, it will read the second line from each CSV file in the given folder and write that line in the Sheet +65:
Option Explicit
Sub ImportCSV65()
Dim strSourcePath As String
Dim strDestPath As String
Dim strFile As String
Dim strData As String
Dim x As Variant
Dim Cnt As Long
Dim r As Long
Dim c As Long
Dim counter As Long
Dim ws As Worksheet: Set ws = Sheets("+65")
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
counter = 0
'Change the path to the source folder accordingly
strSourcePath = Worksheets("Tarpinis").Range("AJ8").Value
If Right(strSourcePath, 1) <> "\" Then strSourcePath = strSourcePath & "\"
strFile = Dir(strSourcePath & "*.csv")
Do While Len(strFile) > 0
Open strSourcePath & strFile For Input As #1
Do Until EOF(1)
Line Input #1, strData
r = ws.Cells(Rows.Count, "A").End(xlUp).Row + 1
counter = counter + 1
If counter = 2 Then 'counter to get only second line
x = Split(strData, ",")
For c = 0 To UBound(x)
ws.Cells(r, c + 1).Value = Trim(x(c))
Next c
r = r + 1
Exit Do
End If
Loop
Close #1
Name strSourcePath & strFile As strSourcePath & strFile
strFile = Dir
counter = 0 'reset counter before next file
Loop
Application.ScreenUpdating = True
End Sub
The only obvious place that I can see that could be done better is the loop that writes the trimmed values into the cells.
If you must trim each value, then you'll still need to loop through the array and Trim it:
For c = 0 To UBound(x)
x(c) = Trim(x(c))
Next c
But to write to the cells, you can speed things up by writing the array directly to the range:
Cells(r, 1).Resize(1, UBound(x) + 1).Value = x
You might also gain a little bit of time by qualifying the destination sheet, preferably as a With.
So the whole thing would look like this:
Sub ImportCSV65()
Dim strSourcePath As String
Dim strDestPath As String
Dim strFile As String
Dim strData As String
Dim x As Variant
Dim Cnt As Long
Dim r As Long
Dim c As Long
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
'Change the path to the source folder accordingly
strSourcePath = Worksheets("Tarpinis").Range("AJ8").Value
If Right(strSourcePath, 1) <> "\" Then strSourcePath = strSourcePath & "\"
strFile = Dir(strSourcePath & "*.csv")
With Sheets("+65")
.Select
Application.ScreenUpdating = False
Do While Len(strFile) > 0
Cnt = Cnt + 1
If Cnt = 1 Then
r = 1
Else
r = .Cells(.Rows.Count, "A").End(xlUp).Row + 1
End If
Open strSourcePath & strFile For Input As #1
If Cnt > 1 Then
Line Input #1, strData
End If
Do Until EOF(1)
Line Input #1, strData
x = Split(strData, ",")
For c = 0 To UBound(x)
x(c) = Trim(x(c))
Next c
.Cells(r, 1).Resize(1, UBound(x) + 1).Value = x
r = r + 1
Loop
Close #1
Name strSourcePath & strFile As strSourcePath & strFile
strFile = Dir
Loop
End With
Application.ScreenUpdating = True
If Cnt = 0 Then _
MsgBox "No CSV files were found...", vbExclamation
Application.ScreenUpdating = False
End Sub
Workbooks.Open Filename:=strSourcePath & strFile, Format:=2
This code will open csv file as excel type.
And get data as variant vlaue and will fill your sheet by variant value.
Sub ImportCSV65()
Dim strSourcePath As String
Dim strDestPath As String
Dim strFile As String
Dim strData As String
Dim Ws As Worksheet, rngT As Range
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
'Change the path to the source folder accordingly
strSourcePath = Worksheets("Tarpinis").Range("AJ8").Value
If Right(strSourcePath, 1) <> "\" Then strSourcePath = strSourcePath & "\"
strFile = Dir(strSourcePath & "*.csv")
Set Ws = Sheets("+65")
Application.ScreenUpdating = False
With Ws
Do While Len(strFile) > 0
Workbooks.Open Filename:=strSourcePath & strFile, Format:=2
With ActiveWorkbook.ActiveSheet
vDB = .UsedRange
End With
ActiveWorkbook.Close
Set rngT = .Range("a" & Rows.Count).End(xlUp)(2)
rngT.Resize(UBound(vDB, 1), UBound(vDB, 2)) = vDB
strFile = Dir
Loop
End With
Application.ScreenUpdating = False
End Sub