I have a xl file with about 2000 rows and columns from A to H. I was trying to sort the file based on the column D such that all other columns are also sorted accordingly (expand selection area).
I am very new to Macros and have been doing this small task to save some time on my reporting.
Here's what I tried:
Prompt the user to select a file
Set the columns from A to H
Sort Range as D2
Save the file
As I said, I am new, I have used much of the code from sample examples in the MSDN library. Apart from Sort(), every thing else is working for me.
here's the code
Sub Select_File_Windows()
Dim SaveDriveDir As String
Dim MyPath As String
Dim Fname As Variant
Dim N As Long
Dim FnameInLoop As String
Dim mybook As Workbook
Dim SHEETNAME As String
'Default Sheet Name
SHEETNAME = "Sheet1"
' Save the current directory.
SaveDriveDir = CurDir
' Set the path to the folder that you want to open.
MyPath = Application.DefaultFilePath
' Open GetOpenFilename with the file filters.
Fname = Application.GetOpenFilename( _
FileFilter:="XLS Files (*.xls),*.xls,XLSX Files (*.xlsx),*.xlsx", _
Title:="Select a file", _
MultiSelect:=True)
' Perform some action with the files you selected.
If IsArray(Fname) Then
With Application
.ScreenUpdating = False
.EnableEvents = True
End With
For N = LBound(Fname) To UBound(Fname)
' Get only the file name and test to see if it is open.
FnameInLoop = Right(Fname(N), Len(Fname(N)) - InStrRev(Fname(N), Application.PathSeparator, , 1))
If bIsBookOpen(FnameInLoop) = False Then
Set mybook = Nothing
On Error Resume Next
Set mybook = Workbooks.Open(Fname(N))
On Error GoTo 0
DoEvents
If Not mybook Is Nothing Then
Debug.Print "You opened this file : " & Fname(N) & vbNewLine
With mybook.Sheets(SHEETNAME)
'Columns("A:H").Sort Key1:=Range("D2:D2000"), Order1:=xlAscending, Header:=xlYes
'Range("A1:H2000").Sort Key1:=Range("D1"), Order1:=xlAscending
Columns("A:H").Sort Key1:=Range("D1"), Order1:=xlAscending, Header:=xlYes
End With
Debug.Print "Sorter Called"
mybook.Close SaveChanges:=True
End If
Else
Debug.Print "We skipped this file : " & Fname(N) & " because it is already open. Please close the data file and try again"
End If
Next N
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End If
End Sub
Function bIsBookOpen(ByRef szBookName As String) As Boolean
On Error Resume Next
bIsBookOpen = Not (Application.Workbooks(szBookName) Is Nothing)
End Function
Nothing is working for me. The file stays as is and No update is made to it. I could not understand, what is the newbie mistake I have been making here ?
Please help.
References:
https://msdn.microsoft.com/en-us/library/office/ff840646(v=office.15).aspx
http://analysistabs.com/vba/sort-data-ascending-order-excel-example-macro-code/
Run time error 1004 when trying to sort data on three different values
It may be as simple as adding a couple of dots (see pentultimate line below)
With mybook.Sheets(SHEETNAME)
'Columns("A:H").Sort Key1:=Range("D2:D2000"), Order1:=xlAscending, Header:=xlYes
'Range("A1:H2000").Sort Key1:=Range("D1"), Order1:=xlAscending
.Columns("A:H").Sort Key1:=.Range("D1"), Order1:=xlAscending, Header:=xlYes
End With
SJR is correct in saying that your references should be fully qualified inside of the With Statement.
You should simplify your subroutines by extracting large blocks of code into separate subroutines. The fewer tasks that a subroutines handles, the easier it is to read and to debug.
Refactored Code
Sub Select_File_Windows()
Const SHEETNAME As String = "Sheet1"
Dim arExcelFiles
Dim x As Long
arExcelFiles = getExcelFileArray
If UBound(arExcelFiles) = -1 Then
Debug.Print "No Files Selected"
Else
ToggleEvents False
For x = LBound(arExcelFiles) To UBound(arExcelFiles)
If IsWorkbookOpen(arExcelFiles(x)) Then
Debug.Print "File Skipped: "; arExcelFiles(x)
Else
Debug.Print "File Sorted: "; arExcelFiles(x)
With Workbooks.Open(arExcelFiles(x))
With .Sheets(SHEETNAME)
.Columns("A:H").Sort Key1:=.Range("D1"), Order1:=xlAscending, Header:=xlYes
End With
.Close SaveChanges:=True
End With
End If
Next
ToggleEvents True
End If
End Sub
Function IsWorkbookOpen(ByRef szBookName As String) As Boolean
On Error Resume Next
IsWorkbookOpen = Not (Application.Workbooks(szBookName) Is Nothing)
End Function
Function getExcelFileArray()
Dim result
result = Application.GetOpenFilename( _
FileFilter:="Excel Workbooks, *.xls; *.xlsx", _
Title:="Select a file", _
MultiSelect:=True)
If IsArray(result) Then
getExcelFileArray = result
Else
getExcelFileArray = Array()
End If
End Function
Sub ToggleEvents(EnableEvents As Boolean)
With Application
.ScreenUpdating = EnableEvents
.Calculation = IIf(EnableEvents, xlCalculationAutomatic, xlCalculationManual)
.EnableEvents = EnableEvents
End With
End Sub
Related
I'm writing a procedure to update the components in one macro-enabled Excel workbook (Destination) from another macro-enabled Excel workbook (Source). The end result is to make the Destination components (worksheets, user forms, modules, etc.) match the Source components.
So far I have successfully (1) Added components from source that are not found in destination, (2) Replaced worksheet(s) with newer versions, (3) Globally updated the code in all modules, class modules and user forms, and (4) Updated miscellaneous cell formulas and values in various worksheets.
Where I have been struggling is deleting components in destination that are not found in source. I've been trying all kinds of approaches and believe I'm close but can't get past various errors in the actual VBComponents.Remove line. Here's my code:
Sub UpdateDest()
'Purpose:
'Sources: (1) https://www.excel-easy.com/vba/examples/import-sheets.html
' (2) https://stackoverflow.com/questions/16174469/unprotect-vbDestProject-from-vb-code
' (3) https://stackoverflow.com/questions/18497527/copy-vba-code-from-a-sheet-in-one-workbook-to-another
'=== Declare Variables
Dim booCompFound As Boolean
Dim cmSrc As CodeModule, cmDest As CodeModule
Dim xlWBDest As Excel.Workbook, xlWSDest As Excel.Worksheet
Dim xlWBSrc As Excel.Workbook, xlWSSrc As Excel.Worksheet
Dim i As Integer, j As Integer
Dim lngVBUnlocked As Long
Dim vbDestComp As Object, vbDestComps As Object, vbDestProj As Object, vbDestMod As Object
Dim vbSrcComp As Object, vbSrcComps As Object, vbSrcProj As Object, vbSrcMod As Object
Dim modModule As Object
Dim strDestName As String, strDestPath As String, strSrcName As String, strSrcPath As String
Dim strUpdName As String, strUpdPath As String
'On Error GoTo ErrorHandler
'=== Initialize Variables and Prepare for Execution
Application.ScreenUpdating = True
Application.DisplayAlerts = True
strUpdPath = ThisWorkbook.Path & "\"
'=== (Code execution)
'--- Select Dest and source workbooks for the update, and remove workbook, worksheet and VBA Project protection from both
strSrcPath = Application.GetOpenFilename(Title:="Select SOURCE workbook for the update", FileFilter:="Excel Files *.xls* (*.xls*),")
If strSrcPath = "" Then
MsgBox "No source workbook was selected.", vbExclamation, "Sorry!"
Exit Sub
Else
Set xlWBSrc = Workbooks.Open(strSrcPath)
UnprotectAll xlWBSrc
'For Each xlWSSrc In xlWBSrc.Worksheets
' xlWSSrc.Visible = xlSheetVisible
'Next xlWSSrc
Set vbSrcProj = xlWBSrc.VBProject
lngVBUnlocked = UnlockProject(vbSrcProj, "FMD090")
Debug.Print lngVBUnlocked
If lngVBUnlocked <> 0 And lngVBUnlocked <> 2 Then
MsgBox "The source VB Project could not be unlocked.", vbExclamation, "Error!"
Exit Sub
Else
Set vbSrcComps = vbSrcProj.VBComponents
End If
End If
strDestPath = Application.GetOpenFilename(Title:="Select DESTINATION workbook to update", FileFilter:="Excel Files *.xls* (*.xls*),")
If strDestPath = "" Then
MsgBox "No destination workbook was selected.", vbExclamation, "Sorry!"
Exit Sub
Else
Set xlWBDest = Workbooks.Open(strDestPath)
UnprotectAll xlWBDest
'For Each xlWSDest In xlWBDest.Worksheets
' xlWSDest.Visible = xlSheetVisible
'Next xlWSDest
Set vbDestProj = xlWBDest.VBProject
lngVBUnlocked = UnlockProject(vbDestProj, "FMD090")
Debug.Print lngVBUnlocked
If lngVBUnlocked <> 0 And lngVBUnlocked <> 2 Then
MsgBox "The destination VB Project could not be unlocked.", vbExclamation, "Error!"
Exit Sub
Else
Set vbDestComps = vbDestProj.VBComponents
End If
End If
'--- Add components from source that are not found in destination
For Each vbSrcComp In vbSrcComps
Debug.Print vbSrcComp.Name
booCompFound = False
For Each vbDestComp In vbDestComps
If vbSrcComp.Name = vbDestComp.Name Then
booCompFound = True
Exit For
End If
Next vbDestComp
If booCompFound = False Then
Application.EnableEvents = False
vbSrcComp.Export strSrcPath & vbSrcComp.Name
vbDestComps.Import strSrcPath & vbSrcComp.Name
Kill strSrcPath & vbSrcComp.Name
Application.EnableEvents = True
End If
Next vbSrcComp
'--- Delete components in destination that are not found in source
Set vbDestComps = vbDestProj.VBComponents
For i = vbDestComps.Count To 1 Step -1
'For Each vbDestComp In vbDestComps
booCompFound = False
For Each vbSrcComp In vbSrcComps
Debug.Print "Src: "; vbSrcComp.Name; " Dest: "; vbDestComps(i).Name
If vbDestComps(i).Name = vbSrcComp.Name Then
booCompFound = True
Exit For
End If
Next vbSrcComp
If booCompFound = False Then
Application.EnableEvents = False
'>>> PROBLEM LINE
vbDestProj.VBComponents.Remove vbDestComps(i)
'<<<
Application.EnableEvents = True
End If
'Next vbDestComp
Next i
'--- Replace worksheet(s) with newer versions
strUpdName = "Lists_WS_3_1.xlsx"
If Dir(strUpdPath & strUpdName) <> "" Then
Application.EnableEvents = False
Set xlWBSrc = Workbooks.Open(strUpdPath & strUpdName)
xlWBDest.Worksheets("Lists").Visible = xlSheetVisible
Application.DisplayAlerts = False
xlWBDest.Worksheets("Lists").Name = "Lists_Old"
xlWBSrc.Worksheets("Lists").Copy After:=xlWBDest.Worksheets("FYMILES")
xlWBDest.Worksheets("Lists_Old").Delete
xlWBSrc.Close
Application.EnableEvents = True
Else
MsgBox "The file " & strUpdName & " is missing.", vbExclamation, "File Missing!"
Exit Sub
End If
'--- Globally update code in modules, class modules and user forms
For Each vbSrcComp In vbSrcComps
Set cmSrc = vbSrcComp.CodeModule
Debug.Print vbSrcComp.Name
Set cmDest = vbDestComps(vbSrcComp.Name).CodeModule
If cmSrc.CountOfLines > 0 Then
Application.EnableEvents = False
cmDest.DeleteLines 1, cmDest.CountOfLines 'Delete all lines in Dest component
cmDest.AddFromString cmSrc.Lines(1, cmSrc.CountOfLines) 'Copy all lines from source component to Dest component
Application.EnableEvents = True
End If
Next vbSrcComp
'--- Update miscellaneous cell formulas and values
Application.EnableEvents = False
xlWBDest.Sheets("Inventory Data and July").Range("E2").Formula = "=TEXT(Lists!$O$5, " & Chr(34) & "000" & Chr(34) & ")"
Application.EnableEvents = True
'=== Error Handling
ErrorHandler:
Application.EnableEvents = True
'=== Release Variables and Cleanup
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
The problem code is about 2/3rds of the way down following '>>> PROBLEM LINE. This line of code produces a run-time error 5, invalid procedure call or argument when attempting to delete the Sheet18 code module.
During the run the original Sheet16 (Lists) is removed and replaced with a new Lists worksheet that Excel numbers Sheet18. After a weekend of contemplation I believe the issue stems from component naming. Attempting to address this, the code references the component names, but VB Properties for the new sheet are (Name) = (Sheet18) and Name = Lists (note the parentheses).
I've now tried saving the workbook following each operation without any change in the error or on what part of the structure the error occurs.
As it is currently written I'm looping backward through the destination components collection and attempting to delete when a component in Destination isn't found in Source. Commented out are the remnants of the original forward loop that also didn't work. I've tried many variations and either get an invalid procedure call or that the property or method isn't found in the object.
I've spend a day playing with this. Please take a look and help me see the light!
I'm running Excel 2016
Following on # Comintern's comment, I added tests to ensure the Remove method was only applied to non-document modules. This is the rewritten code block for removing the modules:
'--- Delete non-document components in destination that are not found in source
Set vbDestComps = vbDestProj.VBComponents
For Each vbDestComp In vbDestComps
If vbDestComp.Type >= 1 And vbDestComp.Type <= 3 Then
booCompFound = False
For Each vbSrcComp In vbSrcComps
Debug.Print "Src: "; vbSrcComp.Name; " Dest: "; vbDestComp.Name; " Type: "; vbDestComp.Type
If vbDestComp.Name = vbSrcComp.Name Then
booCompFound = True
Exit For
End If
Next vbSrcComp
If booCompFound = False Then
Application.EnableEvents = False
vbDestProj.VBComponents.Remove vbDestComp
Application.EnableEvents = True
End If
End If
Next vbDestComp
I have created a macro where I download data into Excel from a software database through an array formula. The scope of the macro is to input a start date and the data is written to individual Excel files and then saved away.
Unfortunately the macro is very slow although I am using the usual code lines to speed up the macro.
Another problem is that the array formula constantly expands the UsedRange with empty lines and thus the file gets bigger and bigger. To counteract this, I delete the empty lines within a For Next loop. Last but not least I still have screen flickering. My guess is the use of DoEvents but I need it for the update of the array formula.Otherwise the code will continue without having the data downloaded.
Below is my code:
Sub Update()
Dim wbTarget As Workbook
Dim objWsInput As Worksheet, objWsMakro As Worksheet, objWsDerivative, objWsFile
Dim Inbox1 As Variant
Dim strFormula As String, strFilename As String, strDate As String
Dim lngDate As Long
Dim dDay As Date
Set objWsInput = ThisWorkbook.Worksheets("INPUT")
'Input start date
Inbox1 = InputBox("Geben Sie bitte ein Start-Datum ein!", Default:=Format(Date, "DD.MM.YYYY"))
Call EventsOff
For dDay = DateSerial(Year(Inbox1), Month(Inbox1), Day(Inbox1)) To DateSerial(Year(Now), Month(Now), Day(Now))
If Weekday(dDay) <> 1 And Weekday(dDay) <> 7 Then
'Convert date into DateValue & string
strDate = Format(dDay, "YYYYMMDD")
lngDate = DateValue(dDay)
'Delete contents
With objWsInput
.Activate
.UsedRange.ClearContents
'Set array formula for QPLIX
strFormula = "=DisplayAllocationWithPreset(""5a9eb7ae2c94dee7a0d0fd5c"", ""5b06a1832c94de73b4194ccd"", " & lngDate & ")"
.Range("A1").FormulaArray = strFormula
'Wait until refresh is done
Do
DoEvents
Loop While Not Application.CalculationState = xlDone
'Copy paste
.Range("A1").CurrentRegion.Copy
.Range("A1").PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
'Call last row and delete depth 0 with number format
i = 2
Call LastRow
For i = CountRow To 2 Step -1
If .Cells(i, 1) = 0 Then .Rows(i).Delete
Next i
Call NumberFormat
'Set file name
strFilename = "Y:\Risikomanagement\Mandate Positions\QPLIX_Mandate_Positions_" & strDate & ".xlsx"
'Open file
Set wbTarget = Workbooks.Add
Set objWsFile = wbTarget.Worksheets(1)
'Copy data into new file
.Range("C1:J" & .Range("A1").CurrentRegion.Rows.Count).Copy Destination:=objWsFile.Range("A1")
'Save file
wbTarget.SaveAs Filename:=strFilename
wbTarget.Close
Call DeleteBlankRows
End With
End If
Next dDay
'Save Workbook
ActiveWorkbook.Save
Call EventsOn
MsgBox "Upload Files erstellt!", vbInformation, "Hinweis"
End Sub
The support functions are as followed:
Public Sub EventsOff()
'Events ausschalten
With Application
.ScreenUpdating = False
.EnableEvents = False
.Calculation = xlCalculationManual
.DisplayAlerts = False
End With
End Sub
Public Sub EventsOn()
'Events anschalten
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = xlCalculationAutomatic
.DisplayAlerts = True
End With
End Sub
To complete my code here are the parts for deleting empty rows & formatting the numbers:
Sub DeleteBlankRows()
Dim MyRange As Range
Dim iCounter As Long
Set MyRange = ActiveSheet.UsedRange
For iCounter = MyRange.Rows.Count To 1 Step -1
'Step 4: If entire row is empty then delete it.
If Application.CountA(Rows(iCounter).EntireRow) = 0 Then
Rows(iCounter).Delete
End If
Next iCounter
End Sub
Sub NumberFormat()
Dim r As Range
For Each r In ActiveSheet.UsedRange.SpecialCells(xlCellTypeConstants)
If IsNumeric(r) Then
r.Value = CDec(r.Value)
r.NumberFormat = "#,##0.00"
End If
Next r
End Sub
Any help is appreciated.Thank you in advance.
Rgds
It seems that DoEvents disables the usual speed up procedures like:
.ScreenUpdating = False
.EnableEvents = False
.Calculation = xlCalculationManual
I changed my code including the support function Call Events Off directly after DoEvents loop and the flickering disappeared. The whole process was also much faster.
I have an existing VBA Project that I simply need to modify even if does scream to be re-written one day.
The sheet has a hidden sheet called Options that lists a file path in B3 and that path is called \fileserver\Drafting\MBS_JOBS\
The code then assigns a variable this path:
strpathtofile = Sheets("Options").Range("B3").Value
Finally, later on, it puts it all together with this:
strFileToOpen = strpathtofile & ActiveCell.Value & strFilename
What I need to do now is have it check a second path. So I've duplicated some of the code.
I first put the new path in B7 of the OPTIONS page. Then, I created a variable and assigned it:
Public strpathtoProj As String
strpathtoProj = Sheets("Options").Range("B7").Value
So, what I need to do is have this program also check this other path. So wondering if I need some kind of IF, THEN or ELSE statement around this part:
strFileToOpen = strpathtofile & ActiveCell.Value & strFilename
To also make it look at strpathtoProj.
I'm a "work in progress" VBA developer as a SOLO IT guy for a small business and am learning as I go.
Here are the modules that use strpathtofile (and you can see that I've already got some code in there for the strpathtoProj that I now need to use):
Sub RUN_SUMMARY_REPORT()
'assign variable... this is here just in case they haven't ran the "TEST" button
strpathtofile = Sheets("Options").Range("B3").Value
strFilename = Sheets("Options").Range("B4").Value
strThisBook = Sheets("Options").Range("B5").Value
strExtraInformation = Sheets("Options").Range("B6").Value
strpathtoProj = Sheets("Options").Range("B7").Value
'assign variable... this is here just in case they haven't ran the "TEST" button
Application.ScreenUpdating = False
Application.DisplayAlerts = False
ActiveSheet.Unprotect
'Remove any past data
SHOW_WARNING (False)
' Extended The Range To Remove data that continued below line 44. Brian
1/20/2015
' Range("C2:C200").ClearContents ' Jobs
Range("F4:S13").ClearContents ' Bar
Range("G17:G23").ClearContents ' Web Plate
Range("J17:J19").ClearContents ' Cable
Range("M17:M23").ClearContents ' Rod
Range("P17:P25").ClearContents ' Angle
'Remove any past data
'initialize ExtraInformation
Sheets(strExtraInformation).Range("A1:K1000").ClearContents
Sheets(strExtraInformation).Select
Range("A1").Select
'initialize ExtraInformation
SHOW_SHEETS (True)
INITIALIZE_PUBLIC_VARS
IMPORT_ALL_INFORMATION
PRINT_WEB_DATA
PRINT_BAR_DATA
PRINT_BRAC_DATA
PRINT_ROD_DATA
PRINT_ANGLE_DATA
SHOW_SHEETS (False)
ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True
End Sub
Sub TEST_FOR_BAD_JOB_MUMBERS()
Dim bFound As Boolean
On Error GoTo EXPLAIN
Application.ScreenUpdating = False 'increase performance
Application.DisplayAlerts = False
'Unhide all sheets
Sheets("REPORT").Visible = True
'Unhide all sheets
'Get all of the settings for this macro and assign variables
strpathtofile = Sheets("Options").Range("B3").Value
strFilename = Sheets("Options").Range("B4").Value
strpathtoProj = Sheets("Options").Range("B7").Value
'Get all of the settings for this macro and assign variables
Sheets("REPORT").Select
ActiveSheet.Unprotect
Range("C2").Select
Do Until ActiveCell.Value = ""
bFound = True
Dim fso As Object
Set fso = CreateObject("Scripting.FileSystemObject") 'Wow! What an
efficiency increase!
If Not fso.FileExists(strpathtofile & ActiveCell & strFilename) Then 'Wow!
What an efficiency increase!
Error (53) 'file not found error
End If
ActiveCell.Font.Color = RGB(0, 0, 0)
ActiveCell.Font.Bold = False
ActiveCell.Offset(1, 0).Select
Loop
Range("c2").Select
'Clean up the look of this thing!
Sheets("Options").Visible = False
Sheets("REPORT").Select
If bFound Then
MsgBox "Test Has Passed! All Job Numbers Found on X-Drive"
Else
MsgBox "No Jobs!"
End If
ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True
Exit Sub
EXPLAIN:
'Clean up the look of this thing!
Sheets("Options").Visible = False
Sheets("REPORT").Select
ActiveCell.Font.Color = RGB(255, 0, 0)
ActiveCell.Font.Bold = True
MsgBox "One Or More Jobs Do Not Exist. Please Check for RED Highlighted
Job."
ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True
End Sub
Sub IMPORT_ALL_INFORMATION()
'Set variables
Dim file_in As Long
Dim strInput As Variant
'end setting variables
Sheets("REPORT").Select
Range("C2").Select
Do Until ActiveCell.Value = "" '//loop through each job
file_in = FreeFile 'next file number
strFileToOpen = strpathtofile & ActiveCell.Value & strFilename
Open strFileToOpen For Input As #file_in
Put_Data_In_Array (file_in)
Organize_Array_For_Print
Close #file_in ' close the file
file_in = file_in + 1
Sheets("REPORT").Select
ActiveCell.Offset(1, 0).Select
Loop
End Sub
Judging by the title of your question this is what you need, but I am a little confused by your question:
sub MainSub()
FileOne = worksheets("SuperSecretHiddenSheet").range("A1").value
FileTwo = worksheets("SuperSecretHiddenSheet").range("A2").value
if bothfileExists(FileOne, FileTwo) = true then
'do stuff
end if
End Sub
function bothfileExists(ByRef FileOne as string, ByRef fileTwo as string) as boolean
if (dir(fileone) <> "" and dir(fileTwo) <> "") then
bothfileExists = True
else
bothfileExists = False
end if
end function
I have to do this whenever I save the excel file:
Save the file at one drive location (overwrite if same name file exists)
Go back to original location of the file and save it there as well (overwrite the file)
Code:
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.DisplayAlerts = False
Dim thisPath As String
Dim oneDrivePath As String
thisPath = ThisWorkbook.Path & "\" & ThisWorkbook.Name
oneDrivePath = "C:\Users\Folder\OneDrive\" & ThisWorkbook.Name
ActiveWorkbook.SaveAs _
Filename:=oneDrivePath
Do
Loop Until ThisWorkbook.Saved
ActiveWorkbook.SaveAs _
Filename:=thisPath
Do
Loop Until ThisWorkbook.Saved
Application.DisplayAlerts = True
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
But this doesn't works it's stucks in an infinte loop or Excel goes in Not Responding State. Anyidea how to achieve this task ?
The reason I can think of why it fails is maybe it's triggered everytime the file is saved but shouldn't Application.EnableEvents = False stop it from happening ? '
EDIT#1:
I tried stepping through the code it goes into Not Responding State after the Code gets though End Sub line
FileCopy may be useful here, since you don't care to overwrite the data, I think that would save you the loop for saved state (since Filesystem Object would take care of resolving the network delays ideally). I'd change the logic to:
1. Save this workbook
2. Overwrite my desired location
3. User is left in the original workbook since you are only saving a copy of this workbook.
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
Dim FileSystemLibrary As Variant: Set FileSystemLibrary = CreateObject("Scripting.FileSystemObject")
Dim thisPath As String: thisPath = ThisWorkbook.Path & "\" & ThisWorkbook.Name
Dim oneDrivePath As String: oneDrivePath = "C:\Users\Folder\OneDrive\" & ThisWorkbook.Name
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.DisplayAlerts = False
ThisWorkbook.Save
FileSystemLibrary.CopyFile FileSystemLibrary.GetFile(thisPath), oneDrivePath
Application.DisplayAlerts = True
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
you don't need to loop if all your doing is saving. try the below
Sub save()
pathForFirstSave = "C:\folder1\"
pathForSecondSave = "C:\anotherFolder\"
ActiveWorkbook.SaveAs Filename:=pathForFirstSave & "asdf.xlsx" _
, FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
ActiveWorkbook.SaveAs Filename:=pathForSecondSave & "asdf.xlsx" _
, FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
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.