Any assistance with this will be very much appreciated.
I'm trying to fill a table in Access with a spreadsheet, and specifying file, sheet and range to read. Unfortunately, the range in excel is not prefixed.
Run-time error 3011: The Microsoft Access database engine could not find the obeject 'SheetName$A:Z10'. Make sure the object exists and that you spell its name and the path name correctly. If 'SheetName$A:Z10' is not a local object, check your network connection or contact the server administrator.
DoCmd.TransferSpreadsheet acImport, 10, "TableName", URL & "\" & fileimport, True, "SheetName!" & "A1:Z" & N - 1
Where N is the number of rows. As you can see, the strings that specify the tab and range debug fine as SheetName!A1:Z10 (for instance N=11), but in the error message, Access has replaced "!" with "$", and the whole thing bugs out.
Any ideas why this is happening, and how to fix it?
Full procedure follows.
Private Sub rapportoExcel_succ(singoloExcel As Integer)
Dim nomefile, SzSQL, URL, Tabella, foglio1, foglio2 As String
Dim N, M As Integer
Dim Workbook1 As Object
Dim ImportList As Boolean
Set wks1 = DBEngine.Workspaces(0)
Set db = wks1.Databases(0)
Set Workbook1 = CreateObject("Excel.Application")
If IsNull(URL_name) Then
URL = CurrentProject.Path
Else
URL = URL_name
End If
If IsNull(Date1) Then
Else
dstep = Date1
End If
qa = MsgBox("Are you sure?", vbYesNo)
If qa <> 6 Then Exit Sub
If Me!ImportList = -1 Or Me.Recordset.EOF Then Me.Recordset.MoveFirst
Do
Me.Repaint
If Me!ImportList = -1 Then
fileimport = Me!nomefile & ".xlsx"
Else
fileimport = NomeDoc1 & ".xlsx"
End If
Workbook1.Workbooks.Open URL & "\" & fileimport, False
Workbook1.Visible = True
Workbook1.DisplayAlerts = False
With Workbook1.ActiveWorkbook
.Unprotect ("a")
foglio1 = .Sheets(3).Name
.Sheets(3).Select
.Unprotect ("a")
.Sheets.Add
.Sheets(3).Move before:=Sheets(1)
.Sheets(1).Name = "SheetName"
.Sheets("FullTable").Select
.Sheets("FullTable").Range("C2").Select
End With
Workbook1.ActiveWorkbook.Sheets("FullTable").Range("C2").FormulaR1C1 = "=COUNTA(R[1]C:R[10000]C)"
N = Workbook1.ActiveWorkbook.Sheets("FullTable").Range("C2").Value + 2
If IsNull(dstep) Then Else dstep = Workbook1.ActiveWorkbook.Sheets("FullTable").Range("B1").Value
Workbook1.ActiveWorkbook.Sheets("FullTable").Range("X3:X" & N).Value = dstep
Workbook1.ActiveWorkbook.Sheets("FullTable").Range("A3:X" & N).Copy
Workbook1.ActiveWorkbook.Sheets("SheetName").Range("A2").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Workbook1.CutCopyMode = False
Workbook1.ActiveWorkbook.Sheets("SheetName").Columns("I").Delete Shift:=xlToLeft
Workbook1.ActiveWorkbook.Sheets("SheetName").Columns("J").Delete Shift:=xlToLeft
Workbook1.ActiveWorkbook.Sheets("SheetName").Columns("K").Delete Shift:=xlToLeft
Workbook1.ActiveWorkbook.Sheets("SheetName").Range("A1").FormulaR1C1 = "F1"
Workbook1.ActiveWorkbook.Sheets("SheetName").Range("B1").FormulaR1C1 = "F2"
With Workbook1.ActiveWorkbook
.Sheets("SheetName").Select
.Sheets("SheetName").Range("A1:B1").AutoFill Destination:=.Sheets("SheetName").Range("A1:Z1"), Type:=xlFillDefault
End With
DoCmd.TransferSpreadsheet acImport, 10, "TableName", URL & "\" & fileimport, True, "SheetName!" & "A1:Z" & N - 1
ActiveWorkbook.Close SaveChanges:=False
If Me!ImportList = -1 Then Me.Recordset.MoveNext
Loop Until Me.Recordset.EOF Or Me!ImportList = 0
MsgBox "Import complete" & IIf(Me.ImportList = 0, "1 group", Me.Recordset.RecordCount & " groups")
Workbook1.Quit
End Sub
The problem with the code is that variables and object are not well defined, starting with Excel App called WorkBook1 instead of ExcelApp. This brings confusion. Rewriting the code and avoiding "Active__" objects fixed all.
Related
I am having issues with my VBA code and am by no means an expert with VBA. This code is tied to product usage data for 30 clients. The current workbook I am using contains multiple tabs but I only want to focus on one tab, the "Template" tab, as my desired output. What I am trying to set up is a macro with an auto save of each individual clients data into its own new workbook in a specific folder location. So basically I only want one tab(ie sheet) saved out of the entire workbook for each client.
The list of clients comes from a data validation list that is tied to a table. Within the macro itself is a .RefreshAll since the data needs to be refreshed for each individual client to produce the output needed in the "Template" tab. The underlying data is tied to both Power Query and T-SQL linked to a MS SQL Server. This is what I am seeing:
When the file is saved I receive a
run time error '1004'
so the saving of the new file fails. In addition, the data refresh needs to run and finish for each individual client before moving on the the next. Which I do not believe is occurring.
Here is how I want the macro to work:
Data refresh begins for first client in data validation drop down list
Refresh completes
"Template" sheet is copy and saved from workbook into a new workbook
New workbook is placed in a new file location
File name includes client name, today's date, and .xlsx extension
VBA code is removed from file that was copied.
Steps 1-6 repeat for the next client until it has gone through entire list of
clients.
Here is the current code I am working with:
Sub ClientDataRefresh()
With ActiveWorkbook.Worksheets("Output")
Dim r As Long, i As Long
r = Range("Clients").Cells.Count
For i = 1 To r
Range("C5") = Range("Clients").Cells(i)
ActiveWorkbook.RefreshAll
Worksheets("Output").Range("A1:O10").Columns.AutoFit
With ActiveWorkbook.Worksheets("Template")
LR = .Cells(Rows.Count, 7).End(xlUp).Row
10: If .Cells(LR, 7) = "" Then LR = LR - 1: GoTo 10
.PageSetup.PrintArea = "$A$1:$I$" & LR
End With
thisDate = Replace(Date, "\", " - ")
thisName = Sheets("Template").Range("H7").Text
filePath = "C:\Users\nalanis\Documents\Sales\"
Application.DisplayAlerts = False
ActiveWorkbook.Worksheets("Template").Select
ActiveWorkbook.Worksheets("Template").Copy
ActiveWorkbook.Worksheets("Template").SaveAs Filename:=filePath & thisName & thisDate & ".xlsx", FileFormat:=xlOpenXMLWorkbook
Application.DisplayAlerts = True
Next i
End With
End Sub
Any feedback is most appreciative. Thank you
NEW CODE
Sub ClientDataRefresh()
With ActiveWorkbook.Worksheets("Output")
Dim r As Long, i As Long
r = Range("Clients").Cells.Count
For i = 1 To r
Range("C5") = Range("Clients").Cells(i)
ActiveWorkbook.RefreshAll
DoEvents
Worksheets("Output").Range("A1:O10").Columns.AutoFit
thisDate = Replace(Date, "/", "-")
thisName = Sheets("Template").Range("H7").Text
filePath = "C:\Users\nalanis\Dropbox (Decipher Dev)\Analytics\Sales\"
Application.DisplayAlerts = False
ActiveWorkbook.Worksheets("Template").Select
ActiveWorkbook.Worksheets("Template").Copy
ActiveWorkbook.Worksheets("Template").SaveAs Filename:=filePath & thisName & " " & "Usage Report" & " " & thisDate & ".xlsx", FileFormat:=xlOpenXMLWorkbook
Application.DisplayAlerts = True
Next i
End With
With ActiveWorkbook.Worksheets("Template")
LR = .Cells(Rows.Count, 7).End(xlUp).Row
10: If .Cells(LR, 7) = "" Then LR = LR - 1: GoTo 10
.PageSetup.PrintArea = "$A$1:$I$" & LR
End With
End Sub
.PageSetup.PrintArea = "$A$1:$I$" & LR
End With
Next c
End Sub
Change this:
thisDate = Replace(Date, "\", " - ")
to this:
thisDate = Replace(Date, "/", " - ")
I have an excel application that often, but not always crashes, when run normally. In case you set a breakpoint and step through the program, it never fails. Likewise if you set breakpoints at strategic places, and then continues executing it generally also works well.
The issue appears to be related to opening a file, copying a large amount of data, and then closing the file. I am however unsure where the program actually crashes. Tips for debugging / methods for finding where the error occurs in the code would be most appreciated.
I have assumed this is due to either a race condition or memory problems, but unsure exactly what would cause either of those errors. Race condition seems more likely though, as pausing or stepping through application shouldn't help with memory issues. If race condition is the cause of the problem, is there a better solution than letting the application sleep/wait at certain points? How do I identify the points where I would need to sleep/wait?
EDIT: When running the application normally it seems to run longer than you would expect, then just closes without any error message. I am running Excel 2013 (32bit) on Win 10.
I considered data being saved to cliboard being the issue, and added
Application.CutCopyMode = False
after each paste, this did not resolve the issue though.
I am supressing alerts and screen updating, i.e.
Application.DisplayAlerts = False
Application.ScreenUpdating = False
but commenting out these settings, still causes application to crash.
EDIT2: Adding the code where the crash occurs. Errors appears to occur somewhere in ReadInAndCopyFiles.
Sub ReadInFiles(wb As Workbook, FolderPath As String, FileName As String)
Dim CurrentWeekDate As Date
Dim TempDate As Date
Dim TempFilePath As String
Dim DataFileName As String
Dim OpenDialog As Office.FileDialog
Dim DateString As String
Dim SheetNameArray As Variant
'Initialization
CurrentWeekDate = wb.Worksheets("Config").Range("EndOfWeekDate").Value
ChDir (FolderPath)
If FileName = "Weekly utilization" Then
SheetNameArray = Array("WeeklyUtilization_CW", "WeeklyUtilization_CW-1", "WeeklyUtilization_CW-2", "WeeklyUtilization_CW-3")
Else
SheetNameArray = Array("Charged Hours", "ChargedHours_CW-1", "ChargedHours_CW-2", "ChargedHours_CW-3")
End If
'Current Week
TempFilePath = FolderPath + FileName + ".xlsx"
ReadInAndCopyFile TempFilePath, CStr(SheetNameArray(0)), "Find " & FileName
'Current Week -1
TempDate = DateAdd("d", -7, CurrentWeekDate)
DateString = Format(TempDate, "yy-mm-dd")
TempFilePath = FolderPath + "Archives\" + FileName + " " + DateString + ".xlsx"
ReadInAndCopyFile TempFilePath, CStr(SheetNameArray(1)), "Find " & FileName & " -1"
'Current Week -2
TempDate = DateAdd("d", -14, CurrentWeekDate)
DateString = Format(TempDate, "yy-mm-dd")
TempFilePath = FolderPath + "Archives\" + FileName + " " + DateString + ".xlsx"
ReadInAndCopyFile TempFilePath, CStr(SheetNameArray(2)), "Find " & FileName & " -2"
'Current Week -3
TempDate = DateAdd("d", -21, CurrentWeekDate)
DateString = Format(TempDate, "yy-mm-dd")
TempFilePath = FolderPath + "Archives\" + FileName + " " + DateString + ".xlsx"
ReadInAndCopyFile TempFilePath, CStr(SheetNameArray(3)), "Find " & FileName & " -3"
End Sub
Sub ReadInAndCopyFile(TempFilePath As String, TargetSheetName As String, CustomMessage As String)
Dim DataFileName As String
Dim SourceWb, wb As Workbook
Dim ws As Worksheet
Dim LastRow, LastColumn, StartRow, TargetLastRow As Variant
Dim OpenDialog As Office.FileDialog
Set wb = ActiveWorkbook
DataFileName = Dir(TempFilePath)
If Not DataFileName <> "" Then
MsgBox CustomMessage
Set OpenDialog = Application.FileDialog(msoFileDialogFilePicker)
OpenDialog.Filters.Clear
OpenDialog.Filters.Add "Excel Files", "*.xlsx"
OpenDialog.AllowMultiSelect = False
OpenDialog.Show
TempFilePath = OpenDialog.SelectedItems(1)
End If
Workbooks.Open FileName:=TempFilePath, UpdateLinks:=False
Set SourceWb = ActiveWorkbook
'Determine where to start pasting, and if header should be included or not
If (wb.Worksheets(TargetSheetName).Cells(Rows.Count, 1).End(xlUp).Row = 1) Then
StartRow = 1
Else
StartRow = wb.Worksheets(TargetSheetName).Cells(Rows.Count, 1).End(xlUp).Row + 1
End If
'Copy First Sheet
LastRow = SourceWb.Worksheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row
'Dont copy any data if blank
If LastRow <> 1 Then
LastColumn = SourceWb.Worksheets("Sheet1").Cells(1, Columns.Count).End(xlToLeft).Column
If StartRow = 1 Then
Range(SourceWb.Worksheets("Sheet1").Cells(1, 1), SourceWb.Worksheets("Sheet1").Cells(LastRow, LastColumn)).Copy
Else
Range(SourceWb.Worksheets("Sheet1").Cells(2, 1), SourceWb.Worksheets("Sheet1").Cells(LastRow, LastColumn)).Copy
End If
wb.Worksheets(TargetSheetName).Range("A" + CStr(StartRow)).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
TargetLastRow = wb.Worksheets(TargetSheetName).Cells(Rows.Count, 1).End(xlUp).Row
End If
'Copy Second Sheet
LastRow = SourceWb.Worksheets("Sheet2").Cells(Rows.Count, 1).End(xlUp).Row
'Dont copy any data if blank
If LastRow <> 1 Then
LastColumn = SourceWb.Worksheets("Sheet2").Cells(1, Columns.Count).End(xlToLeft).Column
'Copy from row 2 to avoid copying headers again
Range(SourceWb.Worksheets("Sheet2").Cells(2, 1), SourceWb.Worksheets("Sheet2").Cells(LastRow, LastColumn)).Copy
wb.Worksheets(TargetSheetName).Range("A" + CStr(TargetLastRow + 1)).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
End If
SourceWb.Close SaveChanges:=False
End Sub
I suspect this bit
Dim OpenDialog As Office.FileDialog
Set wb = ActiveWorkbook
DataFileName = Dir(TempFilePath)
If Not DataFileName <> "" Then
MsgBox CustomMessage
Set OpenDialog = Application.FileDialog(msoFileDialogFilePicker)
OpenDialog.Filters.Clear
OpenDialog.Filters.Add "Excel Files", "*.xlsx"
OpenDialog.AllowMultiSelect = False
OpenDialog.Show
TempFilePath = OpenDialog.SelectedItems(1)
End If
Replace with this
Dim s
Set wb = ActiveWorkbook
datafilename = Dir(tempfilepath)
If datafilename = "" Then
s = Application.GetOpenFilename("*.xlsx,Excel Files", 1, "Select File", , False)
If Not s = False Then
tempfilepath = s
End If
End If
I wasa able to resolve the issue by adding Application.Wait in two places in the code for the sub ReadInAndCopyFile.
'Firstplace
Workbooks.Open FileName:=TempFilePath, UpdateLinks:=False
Application.Wait (Now + TimeValue("0:00:10"))
Set SourceWb = ActiveWorkbook
'Second place
Application.Wait (Now + TimeValue("0:00:10"))
SourceWb.Close SaveChanges:=False
The placement is only due to where I assumed the errors were occurring. It is entirely possible that only one Wait would be enough, and that a shorter wait would be ok. I may do further experimenting later, but for now it is enough that it is running.
Happy to hear if anyone has better or faster methods for resolving this, as this methods as a significant amount of time to the total running time.
I was curious if anybody could provide suggestions on how I can make an excel macro more stable.
The macro prompts the user for a path to a folder containing files to scan. The macro then iterates for every file in this folder.
It opens the excel file, scans Column D for the word fail, then copies that row of data to the data sheet in the excel file where this macro is programmed.
For the most part the macro runs perfectly but sometimes I get run time errors or 'excel has stopped working' errors. I can scan through 5000+ files at a time and the macro takes a while to run.
Any suggestions would be appreciated. Thanks!
Sub findFail()
Dim pathInput As String 'path to file
Dim path As String 'path to file after being validated
Dim fileNames As String 'path to test file
Dim book As Workbook 'file being tested
Dim sheet As Worksheet 'sheet writting data to
Dim sh As Worksheet 'worksheet being tested
Dim dataBook As Workbook 'where data is recorded
Dim row As Long 'row to start writting data in
Dim numTests As Long 'number of files tested
Dim j As Long 'counter for number of files tested
Dim i As Long 'row currently being tested
Dim lastRow As Long 'last row used
Dim startTime As Double 'time when program started
Dim minsElapsed As Double 'time it took program to end
Application.ScreenUpdating = False
j = 0
i = 1
row = 2
Set dataBook = ActiveWorkbook
Set sheet = Worksheets("Data")
sheet.Range("A2:i1000").Clear
startTime = Timer
'-----Prompt for Path-----
pathInput = InputBox(Prompt:="Enter path to files. It must have a \ after folder name.", _
Title:="Single Report", _
Default:="C:\Folder\")
If pathInput = "C:\Folder\" Or pathInput = vbNullString Then 'check to make sure path was inputed
MsgBox ("Please enter a valid file path and try again.")
Exit Sub
Else
path = pathInput 'path = "C:\Temp\212458481\" ' Path for file location
fileNames = Dir(path & "*.xls") 'for xl2007 & "*.xls?" on windows
'-----begin testing-----
Do While fileNames <> "" 'Loop until filename is blank
Set book = Workbooks.Open(path & fileNames)
Set sh = book.Worksheets(1)
lastRow = sh.UsedRange.Rows(sh.UsedRange.Rows.Count).row
If sh.Cells(lastRow, 2).Value - sh.Cells(1, 2).Value >= 0.08333333 Then
Do While sh.Range("D" & i).Value <> "" 'loop untile there are no rows left to test
If sh.Range("D" & i).Value = "Fail" Then 'record values if test result is false
sheet.Range("A" & row).Value = book.Name
sheet.Range("B" & row).Value = Format(sh.Range("B" & i).Value - sh.Range("B1").Value, "h:mm:ss")
sheet.Range("C" & row).Value = sh.Range("A" & i).Value
sheet.Range("D" & row).Value = Format(sh.Range("B" & i).Value, "h:mm:ss")
sheet.Range("E" & row).Value = sh.Range("C" & i).Value
sheet.Range("F" & row).Value = sh.Range("D" & i).Value
sheet.Range("G" & row).Value = sh.Range("E" & i).Value
sheet.Range("H" & row).Value = sh.Range("F" & i).Value
sheet.Range("I" & row).Value = sh.Range("G" & i).Value
row = row + 1
Exit Do
End If
i = i + 1
Loop
j = j + 1
dataBook.Sheets("Summary").Cells(2, 1).Value = j
End If
book.Close SaveChanges:=False
fileNames = Dir()
i = 1
Loop
numTests = j
Worksheets("Summary").Cells(2, "A").Value = numTests
minsElapsed = Timer - startTime
Worksheets("Summary").Cells(2, "B").Value = Format(minsElapsed / 86400, "hh:mm:ss")
End If
End Sub
Without the same dataset as you we, can not definitively supply an answer but I can recommend the below which is related to the error you are seeing.
Try freeing/destroying the references to book and sh.
You have a loop that sets them:-
Do While fileNames <> "" 'Loop until filename is blank
Set book = Workbooks.Open(path & fileNames)
Set sh = book.Worksheets(1)
However the end of the loop does not clear them, ideally it should look as below:-
Set sh = Nothing
Set book = Nothing
Loop
This is a better way to handle resources and should improve memory usage.
As a poor example, without it your code is saying, sh equals this, now it equals this instead, now it equals this instead, now it equals this instead, etc...
You end up with the previous reference that was subsequently overwritten being a sort of orphaned object that is holding some space in memory.
Depending on your case, you may use the following to make it faster -by turning off excel processes that you don't really need at the time of your macro execution-
Sub ExcelBusy()
With Excel.Application
.Cursor = xlWait
.ScreenUpdating = False
.DisplayAlerts = False
.StatusBar = False
.Calculation = xlCalculationManual
.EnableEvents = False
End With
End Sub
In your sub
Dim startTime As Double 'time when program started
Dim minsElapsed As Double 'time it took program to end
Call ExcelBusy
...
As a comment, you never set back screenupdating to true in your sub, that may lead to strange behavior in excel, you should turn everything to default after you are done with your stuff.
OT: Some processes can't be optimized any further -sometimes-, by what you are saying -scanning over 5k files?- surely it's going to take a time, you need to work in how to communicate the user that is going to take a while instead -perhaps an application status bar message or a user form showing process?-.
I'm trying to get a Macro working to merge cells with duplicate data. It will work on small numbers of cells, but I get the following error if I try to run it on a larger group of cells. I'm not sure if there's a more efficient way for excel to run through this.
Run-Time error '1004':
Method 'Range' of object '_Global' failed
Here's the code:
Sub MergeDuplicates()
Dim varData As Variant, varContent As Variant
Dim strMyRange As String
Application.ScreenUpdating = False
Application.DisplayAlerts = False
strMyRange = ActiveCell.Address
varContent = ActiveCell.Value
For Each varData In Selection.Cells
If varData.Value <> varContent Then
strMyRange = strMyRange & ":" & Cells(varData.Row - 1, varData.Column).Address & ", " & Cells(varData.Row, varData.Column).Address
varContent = Cells(varData.Row, varData.Column).Value
End If
Next
strMyRange = strMyRange & Mid(Selection.Address, InStr(1, Selection.Address, ":"), Len(Selection.Address))
Range(strMyRange).Merge
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
I have recreated the issue using the code you posted and it is working for me. I did what you suggested and put the merge into the For loop. Then I split strMyRange using the comma as the delimiter. I set up a test to look for the ":" character in TestArray(0). If it is in that target string, then I know it is ready for the merge. After that I reset strMyRange to the TestArray(1) which is the beginning of the next range.
Note: I was able to step through it with the debugger with 100 cells and it worked. Then I tried running it without any code breakpoints, but it merged all the selected cells. I put a 1 second wait statement right before the final merge and that seems to work.
Here is the code:
Sub MergeDuplicates()
Dim varData As Variant, varContent As Variant
Dim strMyRange As String
Dim TestArray() As String
Dim target As String
Dim pos As Integer
Application.ScreenUpdating = False
Application.DisplayAlerts = False
strMyRange = ActiveCell.Address
varContent = ActiveCell.Value
For Each varData In Selection.Cells
If varData.Value <> varContent Then
strMyRange = strMyRange & ":" & Cells(varData.Row - 1, varData.Column).Address & ", " & Cells(varData.Row, varData.Column).Address
TestArray = Split(strMyRange, ",")
target = TestArray(0)
pos = InStr(target, ":")
If (pos > 0) Then
Range(target).Merge
strMyRange = TestArray(1)
End If
varContent = Cells(varData.Row, varData.Column).Value
End If
Next
strMyRange = strMyRange & Mid(Selection.Address, InStr(1, Selection.Address, ":"), Len(Selection.Address))
Application.Wait (Now + #12:00:01 AM#) 'This helps the application run OK if there are no breakpoints.
Range(strMyRange).Merge
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
I get the data in csv file and I need to import the data into excel. I use the below vba code to complete my task (which I also got from some site after modified accordingly):
Sub ImportTextFile()
Dim vFileName
On Error GoTo ErrorHandle
vFileName = Application.GetOpenFilename("CSV Files (*.csv),*.csv")
If vFileName = False Or Right(vFileName, 3) <> "csv" Then
GoTo BeforeExit
End If
Application.ScreenUpdating = False
Workbooks.OpenText Filename:=vFileName, _
Origin:=xlMSDOS, StartRow:=1, DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, _
ConsecutiveDelimiter:=False, Tab:=False, _
Semicolon:=True, Comma:=False, Space:=False, _
Other:=False, TrailingMinusNumbers:=True, _
Local:=True
Columns("A:A").EntireColumn.AutoFit
BeforeExit:
Application.ScreenUpdating = True
Exit Sub
ErrorHandle:
MsgBox Err.Description
Resume BeforeExit
End Sub
Till now, this code was helping me as the number of rows/records in csv/text file were less than 1,048,576 (which is row limit of excel in a sheet). Now number of records in the csv/text file are 10 times more than the limit.
I need help to
Modify this code, which automatically produces sheets (in the same workbook) and put 1000000 records on each sheet until text/csv file ends.
I appreciate your help on this. thanks
You can try the below code. You need to change the value of numOfLines variable to 1046000 or whatever you need.
Make sure that the Scripting library is switched on in your Excel: Tools > References: Microsoft Scripting Control 1.0 & Microsoft Scriplet Runtime
I tested this code on a .csv file with 80 lines, but I set numOfLines to 10, so I ended up with 8 worksheets each containing just 10 rows from the .csv file.
If you change the numOfLines to 1000000, by extension, it should give you appropriate number of worksheets each containing the specified limit of rows.
Hope this helps.
Sub textStreamToExcel()
'Add Scripting references in Tools before you write this code:
'Microsoft Scripting Control 1.0 and Microsoft Scripting Runtime
Dim numOfLines As Long
numOfLines = 10 '################### change this number to suit your needs
'Enter the source file name
Dim vFileName
vFileName = Application.GetOpenFilename("Text Files (*.txt),*.txt")
If vFileName = False Then
Exit Sub
End If
Dim fso As FileSystemObject
Set fso = New FileSystemObject
Dim ts As TextStream
Dim line As String
Dim counter As Long
Set ts = fso.OpenTextFile(vFileName, ForReading)
Dim wkb As Workbook
Set wkb = Workbooks.Add
wkb.Activate
'Save your file, enter your file name if you wish
Dim vSavedFile
vSavedFile = wkb.Application.GetSaveAsFilename(FileFilter:="Excel Files (*.xls), *.xls")
If vSavedFile = False Then
Exit Sub
End If
wkb.SaveAs vSavedFile
Dim cwks As Integer
cwks = wkb.Sheets.Count
Dim iwks As Integer
iwks = 1
Dim wkbS As Excel.Worksheet
Application.ScreenUpdating = False
Looping:
counter = 1
If iwks <= cwks Then
Set wkbS = wkb.Worksheets(iwks)
wkbS.Activate
Range("A1").Activate
While counter <= numOfLines
If ts.AtEndOfStream <> True Then
line = ts.ReadLine
If ActiveCell.Value = "" Then
ActiveCell.Value = CStr(line)
End If
ActiveCell.Offset(1, 0).Activate
counter = counter + 1
Else
ts.Close
GoTo Ending
End If
Wend
Else
Set wkbS = wkb.Worksheets.Add(After:=Sheets(Sheets.Count))
wkbS.Activate
Range("A1").Activate
While counter <= numOfLines
If ts.AtEndOfStream <> True Then
'If the last line has been read it will give you an Input error
line = ts.ReadLine
If ActiveCell.Value = "" Then
ActiveCell.Value = CStr(line)
End If
ActiveCell.Offset(1, 0).Activate
counter = counter + 1
Else
ts.Close
GoTo Ending
End If
Wend
End If
iwks = iwks + 1
If ts.AtEndOfStream <> True Then
GoTo Looping
Else
GoTo Ending
End If
Ending:
Application.ScreenUpdating = True
Set fso = Nothing
Set ts = Nothing
Set wkb = Nothing
Set wkbS = Nothing
MsgBox "Transfer has been completed"
Exit Sub
ErrorHandler:
MsgBox "The following error has occured:" & Chr(13) & Chr(13) & "Error No: " & Err.Number * Chr(13) & "Description: " & Chr(13) & Err.Description
End Sub
In order to to import this file into Excel, you would need to break it up and place the data on multiple sheets. This is not possible the straight import method you been using. The best you can do would be to read the CSV file with ADO into a Recordset object and then output the Recordset on to the individual sheets while specifying the number of records to be output.
Overall, this will be a fairly slow process. Why are you trying to display this in Excel? Something like Access maybe a better place to store the data (or even keep it in a CSV) and then connect to it from Excel for pivot tables and/or other analysis.