The following code has a problem with calculation.
This calculation finds out the % of rows filled per column. However because of the headers, when a sheet has no values in the columns but has headers it shows as 50%, which isn't correct.
Is there any way to alter this so It doesn't include headers in the calculation? Would this be the best work around?
Sub Stackage()
'added function to skip corrupt files works! Adding skipped files works.. and do something about 50%.
'changed lrw to long, doesnt skip those files now :)
Dim wb As Workbook, fileNames As Object, errCheck As Boolean 'part of loop
Dim ws As Worksheet
Dim resultSheet As Worksheet
Dim i As Long
Dim lco As Integer
Dim lrw As Long
Dim resultRow As Integer
Dim measurement As Double
'To compile skipped files
Dim wksSkipped As Worksheet
Set wksSkipped = ThisWorkbook.Worksheets("Skipped")
Set resultSheet = Application.ActiveSheet
resultRow = 1
'Optimize Macro Speed
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
'get user input for files to search
Set fileNames = CreateObject("Scripting.Dictionary")
errCheck = UserInput.FileDialogDictionary(fileNames)
If errCheck Then Exit Sub
For Each Key In fileNames 'loop through the dictionary
On Error Resume Next
Set wb = Workbooks.Open(fileNames(Key))
If Err.Number <> 0 Then
Set wb = Nothing ' or set a boolean error flag
End If
On Error GoTo 0 ' or custom error handler
If wb Is Nothing Then
wksSkipped.Cells(wksSkipped.Cells(wksSkipped.Rows.Count, "A").End(xlUp).Row + 1, 1) = fileNames(Key)
Else
Debug.Print "Successfully loaded " & fileNames(Key)
wb.Application.Visible = False 'make it not visible
For Each ws In wb.Worksheets
If Not Application.WorksheetFunction.CountA(ws.Cells) = 0 Then
'define the range to measure
lco = ws.Cells.Find("*", , xlValues, xlWhole, xlByColumns, xlPrevious, False).Column
lrw = ws.Columns("A:Y").Find("*", , xlValues, , xlRows, xlPrevious).Row
If lrw = 1 Then lrw = 2
For i = 1 To lco
measurement = Application.WorksheetFunction.CountA(ws.Range(ws.Cells(1, i), ws.Cells(lrw, i))) / lrw
resultSheet.Cells(resultRow, 1).Value = wb.Name
resultSheet.Cells(resultRow, 2).Value = ws.Name
resultSheet.Cells(resultRow, 3).Value = ws.Cells(1, i).Value
resultSheet.Cells(resultRow, 4).Style = "Percent"
resultSheet.Cells(resultRow, 5).Value = measurement
resultRow = resultRow + 1
Next
End If
Next
wb.Application.Visible = True '' I added
wb.Close savechanges:=False 'close the workbook do not save
Set wb = Nothing 'release the object
End If
Next 'End of the fileNames loop
Set fileNames = Nothing
'Message Box when tasks are completed
MsgBox "Task Complete!"
ResetSettings:
'Reset Macro Optimization Settings
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
Function Col_Letter(lngCol As Long) As String
Dim vArr
vArr = Split(Cells(1, lngCol).Address(True, False), "$")
Col_Letter = vArr(0)
End Function
Make one small change to this line:
measurement = Application.WorksheetFunction.CountA(ws.Range(ws.Cells(1, i), ws.Cells(lrw, i))) / lrw
Change it to this:
measurement = ws.Evaluate("sumproduct((" & ws.Range(ws.Cells(2, i), ws.Cells(lrw, i)).Address & "<>"""")+0)") / (lrw - 1)
Related
When I try to export the Sheets to pdf. All of them are split because they are too wide. How can you prevent that from happening? I've searched for something like disabling page break, but I could not implement it correctly perhaps someone knows how. Or setting the range is maybe also a possiblity. Would really like some help.
There are multiple sheets
Thank you guys!
Option Explicit
Sub FilterData()
'DMT32 2017
Dim ws1Master As Worksheet, wsNew As Worksheet, wsFilter As Worksheet
Dim Datarng As Range, FilterRange As Range, objRange As Range
Dim rowcount As Long
Dim colcount As Integer, FilterCol As Integer, FilterRow As Long
Dim SheetName As String, msg As String
'master sheet
Set ws1Master = ActiveSheet
'select the Column filtering
top:
On Error Resume Next
Set objRange = Application.InputBox("Select Field Name To Filter", "Range Input", , , , , , 8)
On Error GoTo 0
If objRange Is Nothing Then
Exit Sub
ElseIf objRange.Columns.Count > 1 Then
GoTo top
End If
FilterCol = objRange.Column
FilterRow = objRange.Row
With Application
.ScreenUpdating = False
.DisplayAlerts = False
End With
On Error GoTo progend
'add filter sheet
Set wsFilter = Sheets.Add
With ws1Master
.Activate
.Unprotect Password:="" 'add password if needed
rowcount = .Cells(.Rows.Count, FilterCol).End(xlUp).Row
colcount = .Cells(FilterRow, .Columns.Count).End(xlToLeft).Column
If FilterCol > colcount Then
Err.Raise 65000, "", "FilterCol Setting Is Outside Data Range.", "", 0
End If
Set Datarng = .Range(.Cells(FilterRow, 1), .Cells(rowcount, colcount))
'extract Unique values from FilterCol
.Range(.Cells(FilterRow, FilterCol), .Cells(rowcount, FilterCol)).AdvancedFilter _
Action:=xlFilterCopy, CopyToRange:=wsFilter.Range("A1"), Unique:=True
rowcount = wsFilter.Cells(wsFilter.Rows.Count, "A").End(xlUp).Row
'set Criteria
wsFilter.Range("B1").Value = wsFilter.Range("A1").Value
For Each FilterRange In wsFilter.Range("A2:A" & rowcount)
'check for blank cell in range
If Len(FilterRange.Value) > 0 Then
'add the FilterRange to criteria
wsFilter.Range("B2").Value = FilterRange.Value
'ensure tab name limit not exceeded
SheetName = Trim(Left(FilterRange.Value, 31))
'check if sheet exists
On Error Resume Next
Set wsNew = Worksheets(SheetName)
If wsNew Is Nothing Then
'if not, add new sheet
Set wsNew = Sheets.Add(after:=Worksheets(Worksheets.Count))
wsNew.Name = SheetName
Else
'clear existing data
wsNew.UsedRange.ClearContents
End If
On Error GoTo progend
'apply filter
Datarng.AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=wsFilter.Range("B1:B2"), _
CopyToRange:=wsNew.Range("A1"), Unique:=False
End If
wsNew.UsedRange.Columns.AutoFit
Set wsNew = Nothing
Next
.Select
End With
progend:
wsFilter.Delete
With Application
.ScreenUpdating = True: .DisplayAlerts = True
End With
If Err > 0 Then MsgBox (Error(Err)), 16, "Error"
End Sub
Sub SaveAsPDF()
Dim ws As Worksheet
For Each ws In Worksheets
ws.ExportAsFixedFormat xlTypePDF, "C:\PDF\" & ws.Name & ".pdf"
Next ws
End Sub
The below code copies data from multiple worksheets and consolidates into database (database worksheet). I am trying to add a new column at the last unused column of database worksheet that gives the name of the sheets in each row, the data is copied from with the column header as "Sheet Name". The problem is, I am trying to start with adding the header by using wsData.Range(1, wsData.Cells(1, Columns.Count).End(xlToLeft).Offset(0, 1)).Value = "SheetName", but unfortunately, it is giving an error.
The program is currently taking 6 minutes to process around 25,000 rows, so is there a way to make it faster?
I am not very well-versed with VBA and I received the below code from another stack overflow question. Below is my code. Any help will be appreciated.
Sub ProcessWorkbooks()
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.DisplayAlerts = False
Dim f, wsData As Worksheet, wbSrc As Workbook, map As Object
Set wsData = ThisWorkbook.Sheets("Database")
wsData.UsedRange.ClearContents 'clear any existing data
Dim fldr1 As FileDialog
Dim iFile As String
Set fldr1 = Application.FileDialog(msoFileDialogFolderPicker)
With fldr1
.Title = "Select InputFile Folder... "
.ButtonName = "Select"
.AllowMultiSelect = False
.InitialFileName = Application.DefaultFilePath
If .Show = -1 Then
iFile = .SelectedItems(1)
Else
Exit Sub
End If
End With
Dim strPath As String
strPath = iFile
Dim oFSO As Object
Dim oFolder As Object
Dim oFile As Object
Set oFSO = CreateObject("Scripting.FileSystemObject")
Set oFolder = oFSO.GetFolder(strPath)
Dim abc As Boolean
abc = False
For Each oFile In oFolder.Files
If oFile.Name Like "*xls*" Then
Set wbSrc = Workbooks.Open(oFolder & "\" & oFile.Name)
ImportData wbSrc, wsData, abc
wbSrc.Close False
End If
Next oFile
With wsData.Range("A1").CurrentRegion
.Font.Size = 9
.Font.Name = "Calibri"
.Borders.LineStyle = xlLineStyleNone
.EntireColumn.AutoFit
End With
Application.ScreenUpdating = True
MsgBox Title:="Task Box", Prompt:="Database Created!"
End Sub
Sub ImportData(wbIn As Workbook, wsData As Worksheet, abc as Boolean)
Dim lrData As Long, lrSrc As Long, ws As Worksheet, c As Range
Dim Process, hdr, m, n
Process = Array("Manila", "Cebu", "Davao", "CDO", "Bacolod")
Application.ScreenUpdating = False
For Each ws In wbIn.Worksheets
Call KillFilter
n = ws.Name
lrData = wsData.Cells(Rows.Count, "A").End(xlUp).Row + 1
'lrData = SheetLastRow(wsData) + 1
If lrData = 1 Then lrData = 2 'in case no headers yet...
lrSrc = SheetLastRow(ws)
For Each c In ws.Range("A1", ws.Cells(1, Columns.Count).End(xlToLeft)).Cells
hdr = c.Value
m = Application.Match(hdr, wsData.Rows(1), 0) 'existing column match?
If IsError(m) Then
m = Application.CountA(wsData.Rows(1))
m = IIf(m = 0, 1, m + 1)
wsData.Cells(1, m).Value = hdr 'add as new column header
End If
ws.Range(c.Offset(1), ws.Cells(lrSrc, c.Column)).Copy _
wsData.Cells(lrData, m)
Next c
If abc = False Then
wsData.Range(1, wsData.Cells(1, Columns.Count).End(xlToLeft).Offset(0, 1)).Value = "SheetName"
abc = True
End If
Next ws
End Sub
'return the last used row in a worksheet
Function SheetLastRow(ws As Worksheet) As Long
Dim f As Range
Set f = ws.Cells.Find("*", ws.Range("A1"), xlFormulas, xlPart, xlByRows, xlPrevious)
If Not f Is Nothing Then SheetLastRow = f.Row 'otherwise 0
End Function
See below for how to add the sheet name, and some other suggestions:
Option Explicit
Sub ProcessWorkbooks()
Dim f, wsData As Worksheet, wbSrc As Workbook, map As Object, strPath As String
Dim oFSO As Object, oFile As Object, nextRow As Long
On Error GoTo haveError 'ensures event/calc settings are restored
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
strPath = ChooseFolder("Select InputFile Folder... ") 'made this a new Function
If Len(strPath) = 0 Then Exit Sub
Set wsData = ThisWorkbook.Sheets("Database")
With wsData
.UsedRange.ClearContents 'clear any existing data
.Range("A1").value = "Sheet Name" 'add the sheet name header
End With
Set oFSO = CreateObject("Scripting.FileSystemObject")
For Each oFile In oFSO.getfolder(strPath).Files
If oFile.name Like "*.xls*" Then
Set wbSrc = Workbooks.Open(oFile.Path)
ImportData wbSrc, wsData
wbSrc.Close False
End If
Next oFile
With wsData.Range("A1").CurrentRegion
.Font.Size = 9
.Font.name = "Calibri"
.Borders.LineStyle = xlLineStyleNone
.EntireColumn.AutoFit
End With
haveError:
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
MsgBox Title:="Task Box", Prompt:="Database Created!"
End Sub
'assumes there's always a "sheet Name" header in A1 of wsData
Sub ImportData(wbIn As Workbook, wsData As Worksheet)
Dim lrData As Long, lrSrc As Long, ws As Worksheet, c As Range
Dim Process, hdr, m
Process = Array("Manila", "Cebu", "Davao", "CDO", "Bacolod") '????
For Each ws In wbIn.Worksheets
If ws.FilterMode Then ws.ShowAllData 'remove any filtering
lrData = wsData.Cells(Rows.Count, "A").End(xlUp).Row + 1 'paste row
lrSrc = SheetLastRow(ws)
wsData.Cells(lrData, "A").Resize(lrSrc - 1).value = ws.name '<<< add the sheet name....
For Each c In ws.Range("A1", ws.Cells(1, ws.Columns.Count).End(xlToLeft)).Cells
hdr = c.value
m = Application.Match(hdr, wsData.Rows(1), 0) 'existing column match?
If IsError(m) Then 'need to add this header?
m = wsData.Cells(1, Columns.Count).End(xlToLeft).Column + 1
wsData.Cells(1, m).value = hdr
End If
ws.Range(c.Offset(1), ws.Cells(lrSrc, c.Column)).Copy _
wsData.Cells(lrData, m)
Next c
Next ws
End Sub
'Ask user to select a folder. Returns empty string if none selected
Function ChooseFolder(prmpt As String) As String
Dim fldr1 As FileDialog, fldr As String
Dim iFile As String
Set fldr1 = Application.FileDialog(msoFileDialogFolderPicker)
With fldr1
.Title = prmpt
.ButtonName = "Select"
.AllowMultiSelect = False
.InitialFileName = Application.DefaultFilePath
If .Show = -1 Then ChooseFolder = .SelectedItems(1)
End With
End Function
'return the last used row in a worksheet
Function SheetLastRow(ws As Worksheet) As Long
Dim f As Range
Set f = ws.Cells.Find("*", ws.Range("A1"), xlFormulas, xlPart, xlByRows, xlPrevious)
If Not f Is Nothing Then SheetLastRow = f.Row 'otherwise 0
End Function
So, I have one excel workbook containing around 80 sheets, the sheets are named as Input, Input(1), input, INPUT, INPUT(2) and Output, Output(1), Output(2), output, OUTPUT and so on, you get the idea... I want to create a macro which creates two mastersheets in the Workbook named "MASTERSHEET INPUT" and "MASTERSHEET Output". The macro should copy all the data from any sheet having any variation of input in its sheet name and paste it one into the MASTERSHEET INPUT and the same goes for the sheets named output which will be pasted into MASTERSHEET OUTPUT. I'm relatively new to VBA and I'd really appreciate it if someone could help me out.
Thanks in advance!
This is the code I was using previously
Sub CombineData()
Dim I As Long
Dim xRg As Range
On Error Resume Next
Worksheets.Add Sheets(1)
ActiveSheet.Name = "MasterSheet"
For I = 2 To Sheets.Count
Set xRg = Sheets(1).UsedRange
If I > 2 Then
Set xRg = Sheets(1).Cells(xRg.Rows.Count + 1, 1)
End If
Sheets(I).Activate
ActiveSheet.UsedRange.Copy xRg
Next
End Sub
But this merges all the sheets in the workbook into one without checking the sheet name.
I tried using this one next but this just pastes the first Output sheet into both mastersheets and then ends:
Sub CombineData()
Dim I As Long
Dim xRg As Range
Dim xWs As Worksheet
Application.ScreenUpdating = False
Application.DisplayAlerts = False
On Error Resume Next
Worksheets.Add Sheets(1)
ActiveSheet.Name = "MasterSheet Output"
For I = 2 To Sheets.Count
Set xRg = Sheets(1).UsedRange
If I > 2 Then
Set xRg = Sheets(1).Cells(xRg.Rows.Count + 1, 1)
End If
For Each xWs In Application.ActiveWorkbook.Worksheets
If xWs.Name = "OUTPUT*" Or xWs.Name = "output*" Or xWs.Name = "Output*" Then
Sheets(I).Activate
ActiveSheet.UsedRange.Copy xRg
End If
Next
Next
On Error Resume Next
Worksheets.Add Sheets(1)
ActiveSheet.Name = "MasterSheet Input"
For I = 3 To Sheets.Count
Set xRg = Sheets(1).UsedRange
If I > 2 Then
Set xRg = Sheets(1).Cells(xRg.Rows.Count + 1, 1)
End If
For Each xWs In Application.ActiveWorkbook.Worksheets
If xWs.Name = "INPUT*" Or xWs.Name = "input*" Or xWs.Name = "Input*" Then
Sheets(I).Activate
ActiveSheet.UsedRange.Copy xRg
End If
Next
Next
Application.DisplayAlerts = True
Application.ScreenUpdating = True
Call DeleteAllSheetsExceptMaster
End Sub
I also tried using this but this does absolutely nothing:
Sub CombineData()
Dim I As Long
Dim xrg As Range
Dim counter As Long
Dim xWs1 As Worksheet
Dim xWs2 As Worksheet
Application.ScreenUpdating = False
Application.DisplayAlerts = False
On Error Resume Next
For counter = 1 To 2
Worksheets.Add Sheets(1)
If counter = 1 Then
ActiveSheet.Name = "MasterSheet Input"
Set xWs1 = ActiveSheet
End If
If counter = 2 Then
ActiveSheet.Name = "MasterSheet Output"
Set xWs2 = ActiveSheet
End If
Next counter
For I = 2 To Sheets.count
Set xrg = Sheets(1).UsedRange
If I > 2 Then
Set xrg = Sheets(1).Cells(xrg.Rows.count + 1, 1)
End If
Sheets(I).Activate
If Sheets(I).Name = "OUTPUT*" Or Sheets(I).Name = "output*" Or Sheets(I).Name = "Output*" Then
ActiveSheet.UsedRange.Copy xWs2
End If
If Sheets(I).Name = "INPUT*" Or Sheets(I).Name = "input*" Or Sheets(I).Name = "Input*" Then
ActiveSheet.UsedRange.Copy xWs1
End If
Next
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
Create Master Sheets
The following will delete each of the master worksheets if they exist and then create new ones. Then it will copy the data from the current region starting in A1 of the defined source worksheets to the appropriate master worksheets (read OP's requirements).
The Code
Option Explicit
Sub createMasterSheets()
' Define constants incl. the Names Arrays and the workbook.
Const srcFirst As String = "A1"
Const tgtFirst As String = "A1"
Dim srcNames As Variant
srcNames = Array("iNpUt", "oUtPuT") ' Case does not matter.
Dim tgtNames As Variant
tgtNames = Array("MasterIn", "MasterOut")
Dim wb As Workbook
Set wb = ThisWorkbook
' Define lower and upper subscripts of the 1D arrays:
' srcNames, tgtNames, Dicts
Dim sFirst As Long
sFirst = LBound(srcNames)
Dim sLast As Long
sLast = UBound(srcNames)
' Turn off screen updating.
Application.ScreenUpdating = False
' Add Target Worksheets.
Dim ws As Worksheet
Dim n As Long
For n = sLast To sFirst Step -1
On Error Resume Next
Set ws = wb.Sheets(tgtNames(n))
On Error GoTo 0
If Not ws Is Nothing Then
Application.DisplayAlerts = False
wb.Sheets(tgtNames(n)).Delete
Application.DisplayAlerts = True
End If
wb.Worksheets.Add Before:=wb.Sheets(1)
ActiveSheet.Name = tgtNames(n)
Next n
' Define Dictionaries Array and populate it with Dictionaries.
' The Dictionaries will hold the Data Arrays.
Dim Dicts As Variant
ReDim Dicts(sFirst To sLast)
Dim dict As Object
For n = sFirst To sLast
Set dict = CreateObject("Scripting.Dictionary")
Set Dicts(n) = dict
Next n
' Declare variables.
Dim wsName As String ' Current Worksheet Name
Dim rng As Range ' Current Source Range, Current Target Cell Range
Dim m As Long ' Subscript of Current Data Array in Current Dictionary
' of Dictionaries Array
' Write values from Source Ranges to Data Arrays.
For Each ws In wb.Worksheets
wsName = ws.Name
For n = sFirst To sLast
If InStr(1, wsName, srcNames(n), vbTextCompare) = 1 Then
' Define Source Range. You might need to do this in another way.
Set rng = ws.Range(srcFirst).CurrentRegion
m = m + 1
Dicts(n)(m) = rng.Value ' This will fail later if one cell only.
Exit For
End If
Next n
Next ws
' Declare variables
Dim Key As Variant ' Current Key in Current Dictionary
' of Dictionaries Array.
' Write values from Data Arrays to Target Ranges.
For n = sFirst To sLast
Set rng = wb.Worksheets(tgtNames(n)).Range(tgtFirst)
Set ws = wb.Worksheets(tgtNames(n))
For Each Key In Dicts(n).Keys
rng.Resize(UBound(Dicts(n)(Key), 1), _
UBound(Dicts(n)(Key), 2)).Value = Dicts(n)(Key)
Set rng = rng.Offset(UBound(Dicts(n)(Key), 1))
Next Key
Next n
' Turn on screen updating.
Application.ScreenUpdating = True
' Inform user.
MsgBox "Sheets created, data transferred.", vbInformation, "Success"
End Sub
See if this works for you.
Edit: fixed case sensitivity.
Sub CopyFromWorksheets()
Dim wrk As Workbook 'Workbook object - Always good to work with object variables
Dim sht As Worksheet 'Object for handling worksheets in loop
Dim trg As Worksheet 'Input Master
Dim trg2 As Worksheet 'Output Master
Dim rng As Range 'Range object
Set wrk = ActiveWorkbook 'Working in active workbook
'Add new worksheet as the last worksheet
Set trg = wrk.Worksheets.Add(After:=wrk.Worksheets(wrk.Worksheets.Count))
'Rename the new worksheet
trg.Name = "Input Master"
'Add new worksheet as the last worksheet
Set trg2 = wrk.Worksheets.Add(After:=wrk.Worksheets(wrk.Worksheets.Count))
'Rename the new worksheet
trg2.Name = "Output Master"
'We can start loop
For Each sht In wrk.Worksheets
'If worksheet in loop is the last one, stop execution (it is Master worksheet)
If sht.Index = wrk.Worksheets.Count - 1 Then
Exit For
ElseIf LCase(sht.Name) Like "*" & "input" & "*" Then
Set rng = sht.Range(sht.Cells(1, 1), sht.Cells(65536, 1).End(xlUp))
'Put data into the Master worksheet
trg.Cells(65536, 1).End(xlUp).Offset(1).Resize(rng.Rows.Count, rng.Columns.Count).Value = rng.Value
ElseIf LCase(sht.Name) Like "*" & "output" & "*" Then
Set rng = sht.Range(sht.Cells(1, 1), sht.Cells(65536, 1).End(xlUp))
'Put data into the Master worksheet
trg2.Cells(65536, 1).End(xlUp).Offset(1).Resize(rng.Rows.Count, rng.Columns.Count).Value = rng.Value
End If
Next sht
'Fit the columns in Master worksheet
trg.Columns.AutoFit
trg.Rows(1).Delete
trg.Columns.AutoFit
trg2.Rows(1).Delete
End Sub
I have the following code but due to the fact that the sheet I'm processing has 190,000 rows of data it is taking 120+ minutes to process all of it:
Start With
Sub Import_Data()
Start_Import "WIR-Deploy"
End Sub
Then this is where I set everything:
Option Explicit
Public WB1 As Workbook
Public WS1 As Worksheet
Public WS2 As Worksheet
Public updateSuccess As Boolean
Sub Start_Import(strApp As String)
Dim WS3 As Worksheet
Dim importFile As String
Set WB1 = ThisWorkbook
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set WS1 = WB1.Sheets("Master Sheet")
If strApp = "WIR-Deploy" Then
Set WS2 = WB1.Sheets("RawWhoIsReady-Deploy#8Jul")
importFile = "H:\99 - Temp\WhoIsReady-Deploy.csv"
Application.StatusBar = "'Who is ready - Deploy' data Import now runnning..."
Else
MsgBox "Not Coded Yet"
Exit Sub
End If
If strApp = "WIR-Deploy" Then
ImportData strApp, importFile
Else
MsgBox "Not Coded Yet"
Exit Sub
End If
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.StatusBar = False
End Sub
and then this imports the sheet:
Option Explicit
Sub ImportData(strApp, importFile)
Dim WB2 As Workbook
Dim WS3 As Worksheet
Dim lRow, lCol, ImportRow As Long
Dim rngAsset As Range
Set WB2 = Workbooks.Open(importFile)
If strApp = "WIR-Deploy" Then
WB2.Sheets(1).Copy Before:=WS2
WB2.Close False
Set WS3 = WB1.ActiveSheet
WS3.Columns(1).EntireColumn.Delete
lRow = Cells(Rows.Count, 1).End(xlUp).Row
lCol = Cells(1, Columns.Count).End(xlToLeft).Column
With WS3
.Sort.SortFields.Add Key:=Range("A1"), Order:=xlAscending
.Sort.SetRange Range(.Cells(1, 1), .Cells(lRow, lCol))
.Sort.Header = xlYes
.Sort.Apply
End With
For ImportRow = 2 To lRow
Set rngAsset = WS1.Range("A:A").Find(WS3.Cells(ImportRow, 1))
If rngAsset Is Nothing Then
WS3.Rows(ImportRow).EntireRow.Delete
ImportRow = ImportRow - 1
lRow = lRow - 1
End If
Application.StatusBar = "[Deploy Import] " & lRow & " left to process. " & ImportRow & " Retained"
Set rngAsset = Nothing
Next
Else
MsgBox "This has not been coded yet", vbOKOnly + vbCritical
Exit Sub
End If
'WS3.Delete
WB1.RefreshAll
End Sub
Is there anyway I can speed this process up ? A better way to do it? My limited knowledge says that i would struggle to make it any quicker but i'm open to any ideas on making it better
Something like this:
Dim m, rngDel As Range, numDel As Long
'...
numDel = 0
For importrow = lRow To 2 Step -1
'Match is much faster than Find...
m = Application.Match(ws3.Cells(importrow, 1).Value, WS1.Range("A:A"), 0)
If IsError(m) Then
numDel = numDel + 1 '<< count rows added
If rngDel Is Nothing Then
Set rngDel = ws3.Rows(importrow)
Else
Set rngDel = Application.Union(rngDel, ws3.Rows(importrow))
End If
'delete in batches
If numDel > 1000 Then
rngDel.Delete
Set rngDel = Nothing
numDel = 0
End If
End If
'don't update statusbar too often
If importrow Mod 1000 = 0 Then
Application.StatusBar = "On row " & importrow
End If
Next
'delete last batch of rows
If Not rngDel Is Nothing Then rngDel.Delete
You can experiment with deleting rngDel once it gets to a certain size: I recall it can get slower to append new rows once the size gets too large...
I used vba to create a TOC for my workbook, but the code formatted my wsname to a number format and removed the leading zeros. Is there a way to modify the code to include the leading zeros in the links?
For example, each of my worksheets is titled with a number beginning with a zero such as "0303855" etc. When I ran this code, my TOC list was numbers without the zero ("303855" etc).
I used the following code:
Sub CreateTOC()
Dim wsA As Worksheet
Dim ws As Worksheet
Dim wsTOC As Worksheet
Dim lRow As Long
Dim rngList As Range
Dim lCalc As Long
Dim strTOC As String
Dim strCell As String
lCalc = Application.Calculation
On Error GoTo errHandler
Application.EnableEvents = False
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
strTOC = "TOC"
strCell = "A1"
Set wsA = ActiveSheet
On Error Resume Next
Set wsTOC = Sheets(strTOC)
On Error GoTo errHandler
If wsTOC Is Nothing Then
Set wsTOC = Sheets.Add(Before:=Sheets(1))
wsTOC.Name = strTOC
Else
wsTOC.Cells.Clear
End If
With wsTOC
.Range("B1").Value = "Sheet Name"
lRow = 2
For Each ws In ActiveWorkbook.Worksheets
If ws.Visible = xlSheetVisible _
And ws.Name <> strTOC Then
.Cells(lRow, 2).Value = ws.Name
.Hyperlinks.Add _
Anchor:=.Cells(lRow, 2), _
Address:="", _
SubAddress:="'" & ws.Name _
& "'!" & strCell, _
ScreenTip:=ws.Name, _
TextToDisplay:=ws.Name
lRow = lRow + 1
End If
Next ws
Set rngList = .Cells(1, 2).CurrentRegion
rngList.EntireColumn.AutoFit
.Rows(1).Font.Bold = True
End With
Application.ScreenUpdating = True
wsTOC.Activate
wsTOC.Cells(1, 2).Activate
exitHandler:
Application.EnableEvents = True
Application.ScreenUpdating = True
Application.Calculation = lCalc
Set rngList = Nothing
Set wsTOC = Nothing
Set ws = Nothing
Set wsA = Nothing
Exit Sub
errHandler:
MsgBox "Could not create list"
Resume exitHandler
End Sub