I run the following code and VBA just flashes for a millisecond and no results are given. No matter how I edit the code, VBA would not execute it.
I am so confused. However, if I run my original code, it works...I try making the same edits to my original code and VBA would run but would stop running after a few tries.
Does anyone know what the heck is going on?
Start Code:
Sub LeadDetailsQR()
Dim OgData As String
OgData = ActiveSheet.Name
Sheets(OgData).AutoFilterMode = False
varMyData = Sheets(OgData).Range("AK2", Range("AK" & Rows.Count).End(xlUp)).Value
With CreateObject("scripting.dictionary")
For Each varItem In varMyData
If Not IsEmpty(varItem) Then .Item(varItem) = Empty
Next varItem
For Each varItem In .keys
Cells.AutoFilter
Sheets.Add Before:=ActiveSheet
Application.DisplayAlerts = False
On Error Resume Next
ActiveWorkbook.Worksheets(varItem).Delete
On Error GoTo 0
Application.DisplayAlerts = True
ActiveSheet.Name = varItem
Sheets(OgData).Select
Sheets(OgData).Range("AK1").AutoFilter Field:=37, Criteria1:=varItem
Sheets(OgData).Cells.CurrentRegion.Copy
Sheets(varItem).Cells.PasteSpecial Paste:=xlPasteColumnWidths
Sheets(OgData).Cells.CurrentRegion.Copy
Sheets(varItem).Cells.PasteSpecial Paste:=xlPasteAll
Next varItem
End With
Sheets(OgData).AutoFilterMode = False
End Sub
Orginal code (works):
Sub LeadDetailsQROriginal()
Dim OgData As String
OgData = ActiveSheet.Name
Sheets(OgData).AutoFilterMode = False
varMyData = Sheets(OgData).Range("A2", Range("A" & Rows.Count).End(xlUp)).Value
With CreateObject("scripting.dictionary")
For Each varItem In varMyData
If Not IsEmpty(varItem) Then .Item(varItem) = Empty
Next varItem
For Each varItem In .keys
Sheets.Add Before:=ActiveSheet
ActiveSheet.Name = varItem
Sheets(OgData).Range("A1").AutoFilter Field:=1, Criteria1:=varItem
Sheets(OgData).Select
Sheets(OgData).Range("A1").CurrentRegion.Copy
Sheets(varItem).Range("A1").PasteSpecial Paste:=xlPasteColumnWidths
Sheets(OgData).Range("A1").CurrentRegion.Copy
Sheets(varItem).Range("A1").PasteSpecial Paste:=xlPasteAll
Next varItem
End With
Sheets(OgData).AutoFilterMode = False
End Sub
I am embarrassed to say that I have found the answer. The code is doing exactly what it is doing. It ran without error because the range it was looking for is blank and as a result, nothing is created.
If I am not being clear, let me explain the code. The code is supposed to create a new sheet based on each unique value in a column. The code ran without producing any results because I was asking the code to look at column AK, which is a blank column. So of course it didn't produce anything :)
Related
I need some help. I am new to Excel VBA. I am trying to create a userform for stock inventory records and I been geting the automation error -2147467259. My problem is that the code works but after a few mouse clicks (10 or more) or after long usage, I keep getting this error. My code:
Private Sub cbPickID_Change()
Application.ScreenUpdating = False
Application.EnableEvents = False
Dim tbl_issuance As ListObject
Set tbl_issuance = shIssuance.ListObjects("tblIssuance")
If Not tbl_issuance.DataBodyRange Is Nothing Then
tbl_issuance.DataBodyRange.Delete
End If
Dim tbl_pick As ListObject
Set tbl_pick = shPickList.ListObjects("tblPickList")
On Error GoTo ErrDetect
With tbl_pick.DataBodyRange
.AutoFilter field:=1, Criteria1:=Me.cbPickID.Value
End With
Dim pick_row As Long
pick_row = shPickList.Range("A" & Application.Rows.Count).End(xlUp).Row
shPickList.Range("A3:L" & pick_row).SpecialCells(xlCellTypeVisible).Copy
shIssuance.Range("A3").PasteSpecial (xlPasteValuesAndNumberFormats)
tbl_pick.AutoFilter.ShowAllData
Application.CutCopyMode = False
Dim issued_row As Long
issued_row = shIssuance.Range("A" & Application.Rows.Count).End(xlUp).Row
With Me.lbPickList
.ColumnHeads = True
.ColumnCount = 12
.ColumnWidths = ("40,40,40,110,0,45,40,60,90,0,0,0")
.RowSource = shIssuance.Range("A3:L" & issued_row).Address
End With
ErrDetect:
If Err.Number = 1004 Then
MsgBox "No records found!"
Exit Sub
End If
Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub
When I click debug, the error point at this
tbl_issuance.DataBodyRange.Delete
all my reference are in the same file. if I want to use the Excel VBA again, I need to close all Excel file and re-open them again.
any advice is highly appreciated.
I'm using the below code to copy column B in combinedWorkbook to column B in ThisWorkbook but when running the macro it seems to paste column B into column C of ThisWorkbook as well as pasting into column B. I've stepped through the code and it works fine. This seems very strange and would be grataeful with any help on why it's also pasting into column C in ThisWorkbook.
Sub ImportWriteOffs()
Dim filter As String
Dim caption As String
Dim combinedFilename As String
Dim combinedWorkbook As Workbook
' Open BRAM Report Source Data
MsgBox ("Select 'SRMF0035 BRAM Pre Repurchase'")
filter = "Text files (*.*),*.*"
caption = "Select 'SRMF0035 BRAM Pre Repurchase'"
combinedFilename = Application.GetOpenFilename(filter, , caption)
If combinedFilename <> "False" Then
Set combinedWorkbook = Application.Workbooks.Open(combinedFilename)
Else
MsgBox "No file was uploaded", vbExclamation
GoTo LastLine
End If
If combinedWorkbook.Worksheets(1).Range("D7").Value = "Periodic Insurance" Then
' Copy and Paste into working file
Sheets("Tabular Version").Select
Range("B10:B100000").Select
Selection.Copy
ThisWorkbook.Activate
Sheets("Input - Write offs").Select
Range("B10:B100000").Select
ActiveSheet.Paste
Application.CutCopyMode = False
combinedWorkbook.Close False
' Delete last row
ThisWorkbook.Activate
Sheets("Input - Write offs").Select
Range("B10").Select
Selection.End(xlDown).Select
Selection.EntireRow.Delete
Else
MsgBox "Incorrect File Selected"
combinedWorkbook.Close False
Exit Sub
End If
LastLine:
End Sub
You can try this. Notice that you do not need to .Select a cell to copy it. It defeats the purpose of VBA! Just get right to the point: State the range and copy it. No need to select.
Also, no need for GoTo as mentioned by the infamous #ashleedawg, just Exit Sub when needed.
Sub ImportWriteOffs()
Dim ws As Worksheet: Set ws = ThisWorkbook.Sheets("Input - Write offs")
Dim filter As String, caption As String, combinedFilename As String
Dim combinedWorkbook As Workbook, ws2 as Worksheet
MsgBox ("Select 'SRMF0035 BRAM Pre Repurchase'")
filter = "Text files (*.*),*.*"
caption = "Select 'SRMF0035 BRAM Pre Repurchase'"
combinedFilename = Application.GetOpenFilename(filter, , caption)
If combinedFilename <> "False" Then
Set combinedWorkbook = Application.Workbooks.Open(combinedFilename)
Set ws2 = combinedWorkbook.Sheets("Tabular Version")
Else
MsgBox "No file was uploaded", vbExclamation
Exit Sub
End If
If combinedWorkbook.Worksheets(1).Range("D7") = "Periodic Insurance" Then
ws2.Range("B10:B" & ws2.Range("B" & ws.Rows.Count).End(xlUp).Row - 1).Copy
ws.Range("B10").PasteSpecial xlPasteValues
ws.Range("B10").PasteSpecial xlPasteFormats
combinedWorkbook.Close False
Else
MsgBox "Incorrect File Selected"
combinedWorkbook.Close False
End If
End Sub
This is happening because the select is actually using a relative reference. But it would be clearer what you want to do if you used Cells instead:
For r = 10 to 10000
ActiveWorkbook.Worksheets("Input - Write-offs").Cells(r, 2) = combinedWorkbook.Worksheets("Tabular Version").Cells(r, 2)
Next
You can implement something similar for deleting the last row, if you are so inclined.
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 this consolidation macro which opens, copies and pastes data from one sheet of several workbooks onto a master sheet where such data as well as workbooks maybe in the thousands. Overall this process will take anywhere from 30mins to an hour and I thought a progress bar would help.
I got the code i used for the consolidation part here at stackoverflow. It was somebody with a similar issue, however, the progress bar code i got somewhere else. I had to jury-rig the code of sorts to fit it for my needs.. The examples online uses a for next loop code for the progress bar which mine doesn't.
i tried running my code but the progress bar doesn't update.. T_T
can somebody help me with what's wrong with my code?
Any help on this is very much appreciated.. thanks..
Sub OpeningFiles()
Dim SelectedFiles As FileDialog
Dim NumFiles As Long, FileIndex As Long
Dim TargetBook As Workbook
Dim sName, sName2, sName3 As Range
Dim pctCompl As Single
Set sName = ThisWorkbook.Sheets("Sheet1").Range("j1")
Set SelectedFiles = Application.FileDialog(msoFileDialogOpen)
With SelectedFiles
.AllowMultiSelect = True
.Title = "Pick the files you'd like to consolidate:"
.ButtonName = ""
.Filters.Clear
.Filters.Add ".xlsx files", "*.xlsx"
.Show
End With
If SelectedFiles.SelectedItems.Count = 0 Then Exit Sub
NumFiles = SelectedFiles.SelectedItems.Count
For FileIndex = 1 To NumFiles
Set TargetBook = Workbooks.Open(SelectedFiles.SelectedItems(FileIndex), ReadOnly:=True)
Application.DisplayAlerts = False
ActiveWorkbook.Activate
Sheets(sName).Activate
On Error GoTo 0
Range("d11:j11").Select
Range(Selection, Selection.End(xlDown)).Copy
ThisWorkbook.Sheets("Sheet1").Activate
Range("b2").Select
Do
If IsEmpty(ActiveCell) = False Then
ActiveCell.Offset(1, 0).Select
End If
Loop Until IsEmpty(ActiveCell) = True
ActiveCell.PasteSpecial Paste:=xlPasteValues
ThisWorkbook.Application.CutCopyMode = False
TargetBook.Close SaveChanges:=False
Next FileIndex
progress pctCompl
MsgBox ("Consolidation complete!")
End Sub
Sub progress(pctCompl As Single)
UserForm1.Text.Caption = pctCompl & "% Completed"
UserForm1.Bar.Width = pctCompl * 2
DoEvents
End Sub
Sub ShowProgress()
UserForm1.Show
End Sub
Addendum:
This code
Sheets(sName).activate
selects the sheetname of the opened file wherein it is always a number from 1-30. Right now, I have to indicate that number one at a time. Is there a way to do it like 3 or 7 times? like a loop? e.g 1-7 or 25-27.. It is always ascending so i thought a code like the one below will work? Thoughts?
For sName = sNameStart To sNameEnd Step 1
Sheets(sName).Activate
On Error GoTo 0
Range("d11:j11").Select
Range(Selection, Selection.End(xlDown)).Copy
ThisWorkbook.Sheets("Sheet1").Activate
Range("b2").Select
Do
If IsEmpty(ActiveCell) = False Then
ActiveCell.Offset(1, 0).Select
End If
Loop Until IsEmpty(ActiveCell) = True
ActiveCell.PasteSpecial Paste:=xlPasteValues
ActiveWorkbook.Activate
Next sName
where sName is the sheet name, sNameStart is the start sheet and sNameEnd is the end sheet.
However, i get this error when I start this code.. Help?
You need to move your call to progress pctCompl inside your loop.
The code you posted doesn't call progress pctCompl until after Next FileIndex
ThisWorkbook.Application.CutCopyMode = False
TargetBook.Close SaveChanges:=False
Next FileIndex
progress pctCompl
MsgBox ("Consolidation complete!")
Replace it with this:
ThisWorkbook.Application.CutCopyMode = False
TargetBook.Close SaveChanges:=False
'insert your command here
progress pctCompl
Next FileIndex
MsgBox ("Consolidation complete!")
If you need something more precise than progress bar try putting:
Application.StatusBar = "File " & FileIndex & " of " & NumFiles
somewhere within For..Next loop, I like this because it is more verbose than just progress bar.
And remember to put
Application.StatusBar = False
After your loop to restore standard status bar.