How to delete empty rows in all Sheets - excel

I am trying to delete empty rows in every sheet using this code in Excel 2010:
Private Sub CommandButton1_Click()
Dim I As Integer
'For all sheets...
For I = 1 To Sheets.Count
'select corresponding sheet
Sheets(I).Select
Sheets(I).Activate
'write delete code
For fila = 1 To 10
If Cells(fila, 4).Value = "" Then
Rows(fila).Delete
End If
Next fila
'Go to next sheet
Next
End Sub
This code only deletes rows on my first active sheet.

Always remember to loop backward when deleting objects (in your case rows), so use For i = 10 to 1 Step -1.
Also, try to avoid using Select and Activate, instead you could directly reference the Worksheet or Range. In this case use directly the ws defined as Worksheet, to see if If ws.Cells(fila, 4).Value = ""
Code
Option Explicit
Private Sub CommandButton1_Click()
Dim I As Integer, fila As Long
Dim ws As Worksheet
' loop through all worksheets
For Each ws In ThisWorkbook.Worksheets
' loop backwards when deleting objects
For fila = 10 To 1 Step -1
If ws.Cells(fila, 4).Value = "" Then ws.Rows(fila).Delete
Next fila
Next ws
End Sub

Maybe this solution will help you :
It will clean all worksheets in your workbook and delete empty rows.
In the end, msg box will tell you the percentage of rows that were deleted for each sheet.
Best regards,
Sub Clean()
Dim Sht As Worksheet, DCell As Range, Calc As Long, Rien As String, Avant As Double, plage As Range
On Error Resume Next
Calc = Application.Calculation ' ---- mémorisation de l'état de
recalcul
'------------------------------------------------------------
MsgBox "Pour le classeur actif : " _
& Chr(10) & ActiveWorkbook.FullName _
& Chr(10) & "dans chaque feuille de calcul" _
& Chr(10) & "recherche la zone contenant des données," _
& Chr(10) & "réinitialise la dernière cellule utilisée" _
& Chr(10) & "et optimise la taille du fichier Excel", _
vbInformation, _
"d'après LL par GeeDee#m6net.fr"
'-------------------------------------------------------------
MsgBox "Taille initiale de ce classeur en octets" _
& Chr(10) & FileLen(ActiveWorkbook.FullName), _
vbInformation, ActiveWorkbook.FullName
'------------------------------------------------------------
With Application
.Calculation = xlCalculationManual
.StatusBar = "Nettoyage en cours..."
.EnableCancelKey = xlErrorHandler
.ScreenUpdating = True
End With
'-------------------- le traitement
For Each Sht In Worksheets
Avant = Sht.UsedRange.Cells.Count
Application.StatusBar = Sht.Name & "-" & Sht.UsedRange.Address
'-------------------Traitement de la zone trouvée
If Sht.UsedRange.Address <> "$A$1" Or Not IsEmpty(Sht.[A1]) Then
Set DCell = Sht.Cells.Find("*", , , , xlByRows, xlPrevious)(2)
'----------------Suppression des lignes inutilisées
If Not DCell Is Nothing Then
Sht.Range(DCell, Sht.Cells([A:A].Count, 1)).EntireRow.Delete
Set DCell = Nothing
Set DCell = Sht.Cells.Find("*", , , , xlByColumns, xlPrevious)(, 2)
'----------------Suppression des colonnes inutilisées
If Not DCell Is Nothing Then Sht.Range(DCell, Sht.[IV1]).EntireColumn.Delete
End If
Rien = Sht.UsedRange.Address
End If
ActiveWorkbook.Save
'---------------------Message pour la feuille traitée
MsgBox "Nom de la feuille de calcul :" _
& Chr(10) & Sht.Name _
& Chr(10) & Format(Sht.UsedRange.Cells.Count / Avant, "0.00%") & " de la taille initiale", _
vbInformation, ActiveWorkbook.FullName
Next Sht
'--------------------Message fin de traitement
MsgBox "Taille optimisée de ce classeur en octets " & Chr(10) & FileLen(ActiveWorkbook.FullName), _
vbInformation, _
ActiveWorkbook.FullNameActive
'--------------------
Application.StatusBar = False
Application.Calculation = Calc
End Sub

Related

Same macro crashes in Excel 365 but works perfectly on Excel 2007

I got a macro that opens 2 workbooks and make some calculations. It works perfectly on Excel 2007 32 bit.
But in Excel 365 64 bits it crashes right after opening the first workbook, with no messages errors. Excel quits directly with no warning.
After some testing, I think it fails right after asking first workbook. The code is:
Sub PROCESO(ByVal EstasHojas As String)
Dim WBSource As Workbook
Dim WBDestiny As Workbook
Dim WKSource As Worksheet
Dim WKDestiny As Worksheet
Dim WBintermedio As Workbook
Dim WKIntermedia As Worksheet
Dim Ruta As String
Dim MiMatriz As Variant
Dim MatrizCampos As Variant
Dim LR As Long
Dim LC As Long
Dim i As Long
Dim j As Long
Dim MiF As WorksheetFunction: Set MiF = WorksheetFunction
Dim FechaPrevista As Long
Dim FechaReal As Long
Dim PagoEur As Long
Dim Proveedor As Long
Dim MatrizHojas As Variant
Dim NoHayDatos As Byte
Dim STRColor As String
Dim MatrizFinal() As Variant
Dim DictFechas As Object
Dim FechaDict As Variant
RutaCostIncomes = ""
RutaCashflow = ""
Application.Calculation = xlCalculationManual
'primero total hojas
MatrizHojas = Split(EstasHojas, "||")
With Application.FileDialog(msoFileDialogFilePicker)
.Title = "Seleccione archivo COST AND INCOMES"
.AllowMultiSelect = False
If .Show = False Then
MsgBox "No se ha seleccionado ningún archivo.", vbCritical, "PROCESO ABORTADO"
GoTo Final
Else
Ruta = .SelectedItems(1)
Set WBSource = Application.Workbooks.Open(Ruta)
DoEvents
End If
End With
Stop
'//////////////////////////////////////añadimos primero comprobación de que cada campo sea del tipo que le corresponde.
' se crean variables solo para esta comprobación y no se usarán más
Dim HayDatosMal As Boolean
Dim WKErrores As Worksheet
Dim KK As Long
KK = 3
HayDatosMal = False
For j = 0 To UBound(MatrizHojas) - 1 Step 1
Set WKSource = Nothing
Set WKSource = WBSource.Worksheets(CByte(MatrizHojas(j))) 'la posición de la hoja
LR = WKSource.Range("A" & WKSource.Rows.Count).End(xlUp).Row
Dim ZZ As Long
For ZZ = 12 To 3 Step -1
Select Case ZZ
Case 3, 4, 9, 10 'son campos de fechas
For i = 2 To LR Step 1
If IsDate(WKSource.Cells(i, ThisWorkbook.Worksheets("PANEL CONTROL").Range("C" & ZZ).Value)) = False And WKSource.Cells(i, ThisWorkbook.Worksheets("PANEL CONTROL").Range("C" & ZZ).Value) <> "" Then
HayDatosMal = True
If WKErrores Is Nothing Then Set WKErrores = Application.Workbooks.Add.ActiveSheet
With WKErrores
.Range("A1").Value = "INFORME DE ERRORES ENCONTRADOS"
.Range("A3").Value = "HOJA"
.Range("B3").Value = "FILA"
.Range("C3").Value = "CAMPO"
KK = KK + 1
.Range("A" & KK).Value = UCase(WKSource.Name)
.Range("B" & KK).Value = i
.Range("C" & KK).Value = UCase(ThisWorkbook.Worksheets("PANEL CONTROL").Range("A" & ZZ).Value)
End With
End If
Next i
Case 5, 11 'tienen que ser numéricos
For i = 2 To LR Step 1
If IsNumeric(WKSource.Cells(i, ThisWorkbook.Worksheets("PANEL CONTROL").Range("C" & ZZ).Value)) = False And WKSource.Cells(i, ThisWorkbook.Worksheets("PANEL CONTROL").Range("C" & ZZ).Value) <> "" Then
HayDatosMal = True
If WKErrores Is Nothing Then Set WKErrores = Application.Workbooks.Add.ActiveSheet
With WKErrores
.Range("A1").Value = "INFORME DE ERRORES ENCONTRADOS"
.Range("A3").Value = "HOJA"
.Range("B3").Value = "FILA"
.Range("C3").Value = "CAMPO"
KK = KK + 1
.Range("A" & KK).Value = UCase(WKSource.Name)
.Range("B" & KK).Value = i
.Range("C" & KK).Value = UCase(ThisWorkbook.Worksheets("PANEL CONTROL").Range("A" & ZZ).Value)
End With
End If
Next i
Case Else 'son textos o están vacíos, no hacemos nada
DoEvents
End Select
Next ZZ
Next j
If HayDatosMal = True Then
'hay que abortar proceso
WBSource.Close False
WKErrores.Activate
WKErrores.Columns("A:C").EntireColumn.AutoFit
Set WKErrores = Nothing
MsgBox "Se cancela el proceso porque se han encontrado errores en los datos de origen. Se ha generado un informe de errores para consultar.", vbCritical, "PROCESO CANCELADO"
GoTo Final
End If
DoEvents
'////////////////////// fin comprobación
'compruebo que los campos coincida con mis datos del configurador
MatrizCampos = ThisWorkbook.Worksheets("PANEL CONTROL").Range("A2").CurrentRegion.Value
'compruebo todas las hojas
For j = 0 To UBound(MatrizHojas) - 1 Step 1
Set WKSource = Nothing
Set WKSource = WBSource.Worksheets(CByte(MatrizHojas(j))) 'la posición de la hoja
With WKSource
'los campos empiezan en la fila 2 de los datos de la matriz de campos
'comprobamos que en source estén con el mismo nombre en su posición
For i = 2 To UBound(MatrizCampos) Step 1
If MiF.CountIf(.Rows(1), MatrizCampos(i, 1)) = 0 Then
'el campo no está presente. Abortamos
MsgBox "El campo " & UCase(MatrizCampos(i, 1)) & " no está en la hoja " & WKSource.Index & " de COST AND INCOMES", vbCritical, "PROCESO ABORTADO"
WBSource.Close False
GoTo Final
Else
'compruebo que esté en su posición
LR = MiF.Match(MatrizCampos(i, 1), .Rows(1), 0)
If LR <> MatrizCampos(i, 3) Then
'no está donde marca el PANEL CONTROL
MsgBox "El campo " & UCase(MatrizCampos(i, 1)) & " no está en la posición que marca PANEL CONTROL en la hoja " & WKSource.Index & " de COST AND INCOMES", vbCritical, "PROCESO ABORTADO"
WBSource.Close False
GoTo Final
End If
End If
Next i
End With
Next j
Set WKSource = Nothing
'también comprobamos los campos de ingresos
MatrizCampos = ThisWorkbook.Worksheets("PANEL CONTROL").Range("A8").CurrentRegion.Value
'compruebo todas las hojas
For j = 0 To UBound(MatrizHojas) - 1 Step 1
Set WKSource = Nothing
Set WKSource = WBSource.Worksheets(CByte(MatrizHojas(j))) 'la posición de la hoja
With WKSource
'los campos empiezan en la fila 2 de los datos de la matriz de campos
'comprobamos que en source estén con el mismo nombre en su posición
For i = 2 To UBound(MatrizCampos) Step 1
If MiF.CountIf(.Rows(1), MatrizCampos(i, 1)) = 0 Then
'el campo no está presente. Abortamos
MsgBox "El campo " & UCase(MatrizCampos(i, 1)) & " no está en la hoja " & WKSource.Index & " de COST AND INCOMES", vbCritical, "PROCESO ABORTADO"
WBSource.Close False
GoTo Final
Else
'compruebo que esté en su posición
LR = MiF.Match(MatrizCampos(i, 1), .Rows(1), 0)
If LR <> MatrizCampos(i, 3) Then
'no está donde marca el PANEL CONTROL
MsgBox "El campo " & UCase(MatrizCampos(i, 1)) & " no está en la posición que marca PANEL CONTROL en la hoja " & WKSource.Index & " de COST AND INCOMES", vbCritical, "PROCESO ABORTADO"
WBSource.Close False
GoTo Final
End If
End If
Next i
End With
Next j
Set WKSource = Nothing
MatrizCampos = ThisWorkbook.Worksheets("PANEL CONTROL").Range("A2").CurrentRegion.Value
'the code never reachs this part when it crashes
EstasHojas is just a string that contains text like 1|2|
I've read this but could not find a solution.
VBA force closes Excel 365 but works fine in Excel 2019
64-bit Excel 365 crashes, 32-bit Excel 365 works fine
Also tried adding DoEvents right after opening the workbook with no luck.
No add-ins involved at all.
Now comes the funny part. If I add a Stop command right after opening the first workbook, and then VBa stops there, I press F5 so macro keeps going, everything works perfect!
With Application.FileDialog(msoFileDialogFilePicker)
.Title = "Seleccione archivo COST AND INCOMES"
.AllowMultiSelect = False
If .Show = False Then
MsgBox "No se ha seleccionado ningún archivo.", vbCritical, "PROCESO ABORTADO"
GoTo Final
Else
Ruta = .SelectedItems(1)
Set WBSource = Application.Workbooks.Open(Ruta)
DoEvents
End If
End With
Stop 'this fixes everything
So if I try to execute all at once, it crashed with no errors. But if I force it to make a break and then continue, it works.
I would like to know why adding the Stop makes the code works perfectly on Eccel 365 but without it it crashed and closes Excel with no errors. Tried DoEvents as I said, but it did not help in this case.
By the way, the workbooks opened are just data in XLSX files, no other macros or events. Just this code. I can post the full code if needed but it's really long.
Thanks in advance.

VBA : Me.Name function

I have a spreadsheet xlsm "My_workfile1", I would like to Save As this file like "My_final_workfile_1.xlsm".
I would like to hold all data in "My_final_workfile_1" and have the cells C4,C6,C7,C11,C12 in initial file "My_workfile1" empty after closing.
My code is:
Sub logFormState()
Sheets("1 - Feuille de Suivi ").Range("C4") = ""
Sheets("1 - Feuille de Suivi ").Range("C6") = ""
Sheets("1 - Feuille de Suivi ").Range("C7") = ""
Sheets("1 - Feuille de Suivi ").Range("C11") = ""
Sheets("1 - Feuille de Suivi ").Range("C12") = ""
End Sub
Public Sub Workbook_BeforeClose(Cancel As Boolean)
If Me.Name = "My_workfile1" Then
Call logFormState
End If
End Sub
But Me.Name function doesn't work. I'm wondering if my code is correct.
Thank you for your help!
Workbook BeforeClose
Workbook.BeforeClose event
Workbook.SaveCopyAs method
The first procedure is here only to help you to get your names right. It will show the names (and the folder path and the file path) in the Immediate window (CTRL+G).
The Code
Option Explicit
Sub DebugPrint()
With ThisWorkbook
Debug.Print "Workbook:"
Debug.Print """" & .FullName & """"
Debug.Print """" & .Path & """"
Debug.Print """" & .Name & """"
Debug.Print "Worksheet Names:"
Dim ws As Worksheet
For Each ws In ThisWorkbook.Worksheets
Debug.Print """" & ws.Name & """"
Next ws
End With
End Sub
Sub logFormState()
' Note that this worksheet name ends with a space!
With ThisWorkbook.Worksheets("1 - Feuille de Suivi ")
.Range("C4,C6,C7,C11,C12") = ""
' Either save here...
.Parent.Save
End With
End Sub
Public Sub Workbook_BeforeClose(Cancel As Boolean)
If Me.Name = "My_workfile_1.xlsm" Then
' Change the path if necessary.
Me.SaveCopyAs Me.Path & "\" & "My_final_workfile_1.xlsm"
Call logFormState
'... or save here:
'.Save
End If
End Sub

Create A Pivot Chart Using VBA Resulting In A Runtime 5 Error

Im trying to create a pivot chart through VBA (So a button can create the pie chart based on dynamic values from a form)
My code is:
Dim iRow As Long
'//Find First Empty Row In Database
iRow = Sheets("search results").Cells.Find(What:="*", SearchOrder:=xlRows, _
SearchDirection:=xlPrevious, LookIn:=xlValues).Row
Sheets("Custom Chart").visible = True
ActiveWorkbook.PivotCaches.Create(SourceType:=xlDatabase, SourceData:= _
"Search Results!A3:AM" & iRow, Version:=xlPivotTableVersion14). _
CreatePivotTable TableDestination:="Custom Chart!A1", TableName:="PivotTable6" _
, DefaultVersion:=xlPivotTableVersion14
Sheets("Custom Chart").Select
Cells(1, 1).Select
ActiveSheet.Shapes.AddChart.Select
ActiveChart.ChartType = xlColumnClustered
ActiveChart.SetSourceData Source:=Range("Custom Chart!$A$1:$C$18")
ActiveSheet.Shapes("Chart 1").IncrementLeft 192
ActiveSheet.Shapes("Chart 1").IncrementTop 15
ActiveSheet.PivotTables("PivotTable6").AddDataField ActiveSheet.PivotTables( _
"PivotTable6").PivotFields("Ethnicity Of Child"), "Count of Ethnicity Of Child" _
, xlCount
With ActiveSheet.PivotTables("PivotTable6").PivotFields(Me.Dy4.Value)
.Orientation = xlRowField
.Position = 1
End With
ActiveChart.ChartType = xlPie
ActiveChart.ApplyLayout (6)
ActiveChart.Location Where:=xlLocationAsNewSheet, Name:="Chart Result"
ActiveWorkbook.ShowPivotTableFieldList = False
My code fails on this line:
ActiveWorkbook.PivotCaches.Create(SourceType:=xlDatabase, SourceData:= _
"Search Results!A3:AM" & iRow, Version:=xlPivotTableVersion14). _
CreatePivotTable TableDestination:="Custom Chart!A1", TableName:="PivotTable6" _
, DefaultVersion:=xlPivotTableVersion14
Saying that a runtime 5 error has occurred. The only reason I can think of is that I'm trying to use cell references to define a range, I noticed that if you record creating a pivot chart, it uses ranges like Sheet1!R1C1, but I don't understand those references.
Any help would be appreciated.
Thanks in advance.
I fixed the problem myself,
Heres the complete code for generating a chart off of a form with variables:
Private Sub Creat_Chart_Click()
Worksheets.Add().Name = "Custom Chart"
If Me.R_End.Value = "" Or _
Me.R_Start.Value = "" Or _
Me.Chart_List.Value = "" Or _
Me.Data_List.Value = "" Or _
Me.Dy2.Value = "" Or _
Me.Dy4.Value = "" Then
MsgBox "Information is missing from the form"
Exit Sub
End If
Dim ws As Worksheet
Set ws = Worksheets("database")
Sheets("Settings").Range("Start_Date").Value = Format(Me.R_Start.Value, "mm/dd/yyyy")
Sheets("Settings").Range("End_Date").Value = Format(Me.R_End.Value, "mm/dd/yyyy")
'Collect Start & End Dates
Dim dStartDate As Long
Dim dEndDate As Long
dStartDate = Sheets("Settings").Range("Start_Date").Value
dEndDate = Sheets("Settings").Range("End_Date").Value
ws.Activate
'On Error GoTo error_Sdate:
RowNum = Application.WorksheetFunction.Match(dStartDate, Range("B1:B60000"), 0)
' MsgBox "Found " & Format(dStartDate, "dd/mm/yyyy") & " at row : " & RowNum
'On Error GoTo error_Edate:
RowNumEnd = Application.WorksheetFunction.Match(dEndDate, Range("B1:B60000"), 1)
' MsgBox "Found " & Format(dEndDate, "dd/mm/yyyy") & " at row : " & RowNumEnd
GoTo J1
error_Sdate:
Dim msg As String
msg = "You entered " & Format(dStartDate, "dd/mm/yyyy") & " as your Start Date, but no referrals were made on that date"
msg = msg & vbCrLf & "Please enter a different date in the Start Date box"
MsgBox msg, , "Start Date Not Found"
Err.Clear
Exit Sub
error_Edate:
msg = "You entered " & Format(dEndDate, "dd/mm/yyyy") & " as your End Date, but no referrals were made on that date"
msg = msg & vbCrLf & "Please enter a different date in the End Date box"
MsgBox msg, , "End Date Not Found"
Err.Clear
Exit Sub
J1:
Dim CR_1 As Integer
Dim CR1 As Integer
'// Get Criteria From Form And Search Database Headers
If Me.Data_List.Value = "Display Variable By Agency Of Referrer" Then
CR1 = 3
End If
If Me.Data_List.Value = "Display Variable By Agency Of Allegee" Then
CR1 = 4
End If
Set ws = Worksheets("database")
Set ps = Worksheets("Search Results")
ps.Range("A3:AM60000").Clear
'Dim RowNum As Variant
'Dim RowNumEnd As Variant
For i = RowNum To RowNumEnd
If ws.Cells(i, CR1).Value = Me.Dy2.Value Then
ws.Range("A" & i & ":AM" & i).Copy
ps.Activate
'find first empty row in database
emR = ps.Cells.Find(What:="*", SearchOrder:=xlRows, _
SearchDirection:=xlPrevious, LookIn:=xlValues).Row + 1
ps.Range("A" & emR & ":AM" & emR).PasteSpecial
End If
Next i
Dim wksSource As Worksheet
Dim wksDest As Worksheet
Dim rngSource As Range
Dim rngDest As Range
Dim LastRow As Long
Dim LastCol As Long
Set wksSource = Worksheets("Search Results")
Set wksDest = Worksheets("Custom Chart")
With wksSource
LastRow = .Range("A2").End(xlDown).Row
LastCol = .Range("A2").End(xlToRight).Column
Set rngSource = .Range("A2", .Cells(LastRow, LastCol))
End With
Set rngDest = wksDest.Range("A1")
wksDest.Activate
' If wksDest.PivotTables.count > 0 Then
'
'
' wksDest.Range("A:Z").Delete
'
'
' End If
ActiveSheet.PivotTableWizard _
SourceType:=xlDatabase, _
SourceData:=rngSource, _
TableDestination:=rngDest, _
TableName:="Pivotinfo"
With wksDest.PivotTables("Pivotinfo")
.PivotFields(Me.Dy4.Value).Orientation = xlRowField
.PivotFields(Me.Dy4.Value).Orientation = xlDataField
End With
Dim CC As Worksheet
Dim CCR, CCC As Long
Set CC = Sheets("Custom Chart")
CCR = CC.Cells.Find(What:="*", SearchOrder:=xlRows, _
SearchDirection:=xlPrevious, LookIn:=xlValues).Row
CCC = CC.Cells.Find(What:="*", SearchOrder:=xlRows, _
SearchDirection:=xlPrevious, LookIn:=xlValues).Column
Range("A1").Select
ActiveWorkbook.Charts.Add
ActiveChart.ChartType = xlPie
ActiveChart.ApplyLayout (4)
ActiveChart.SetElement (msoElementChartTitleAboveChart)
ActiveChart.SetElement (msoElementLegendRight)
ActiveChart.ApplyDataLabels
ActiveChart.SeriesCollection(1).DataLabels.Select
Selection.ShowPercentage = True
Selection.ShowCategoryName = False
Selection.Separator = "" & Chr(10) & ""
If CR1 = 3 Then
ActiveChart.ChartTitle.Characters.Text = Me.Dy4.Value & " Referred By " & Me.Dy2.Value & _
" Between The Dates " & Me.R_Start.Value & " & " & Me.R_End.Value
End If
If CR1 = 4 Then
ActiveChart.ChartTitle.Characters.Text = Me.Dy4.Value & " Referred By " & Me.Dy2.Value & _
" Between The Dates " & Me.R_Start.Value & " & " & Me.R_End.Value
End If
Application.DisplayAlerts = False
Worksheets("Custom Chart").Delete
Application.DisplayAlerts = True
End Sub
I got around the issue by deleting the custom chart sheet and re-creating it to get rid of the pivot table so I could create a new one with the same name. Not the tidiest method, but it works

Storing output in temporary sheet for sorting

Following on from this question, Defining a range from values in another range, (thanks Siddharth!) I want to edit the code to list the the tasks in order by most amount of days to shortest. Had a brief comment chat with Siddharth where he suggested the best way would be to create a temp sheet containing the data, sort that by arrived data and create the message box, before deleting the temp sheet. Any ideas where to start? Can I export the msg string to a new sheet or does it need to be a variable other t to be stored in a sheet
Option Explicit
Sub Notify()
Dim WS1 As Worksheet
Dim Chk As Range, FltrdRange As Range, aCell As Range
Dim ChkLRow As Long
Dim msg As String
On Error GoTo WhatWentWrong
Application.ScreenUpdating = False
Set WS1 = Sheets("Ongoing")
With WS1
ChkLRow = .Range("C" & Rows.Count).End(xlUp).Row
'~~> Set your relevant range here
Set Chk = .Range("A1:K" & ChkLRow)
'~~> Remove any filters
ActiveSheet.AutoFilterMode = False
With Chk
'~~> Filter,
.AutoFilter Field:=3, Criteria1:="NO"
'~~> Offset(to exclude headers)
Set FltrdRange = .Offset(1, 0).SpecialCells(xlCellTypeVisible)
'~~> Remove any filters
ActiveSheet.AutoFilterMode = False
For Each aCell In FltrdRange
If aCell.Column = 8 And _
Len(Trim(.Range("B" & aCell.Row).Value)) <> 0 And _
Len(Trim(aCell.Value)) <> 0 Then
msg = msg & vbNewLine & _
"Request for contractor code " & .Range("B" & aCell.Row).Value & _
" dispensing month " & .Range("A" & aCell.Row).Value & _
" has been in the cupboard for " & _
DateDiff("d", aCell.Value, Date) & " days."
End If
Next
End With
End With
'~~> Show message
MsgBox msg
Reenter:
Application.ScreenUpdating = True
Exit Sub
WhatWentWrong:
MsgBox Err.Description
Resume Reenter
End Sub
Is this what you are trying?
Option Explicit
Sub Notify()
Dim WS1 As Worksheet, TmpSht As Worksheet
Dim Chk As Range, FltrdRange As Range, aCell As Range
Dim ChkLRow As Long, TSLastRow As Long, i As Long
Dim msg As String
On Error Resume Next
Application.DisplayAlerts = False
Sheets("Alistair_Weir").Delete
Application.DisplayAlerts = True
On Error GoTo 0
On Error GoTo WhatWentWrong
Application.ScreenUpdating = False
Set WS1 = Sheets("Ongoing")
With WS1
ChkLRow = .Range("C" & Rows.Count).End(xlUp).Row
'~~> Set your relevant range here
Set Chk = .Range("A1:K" & ChkLRow)
'~~> Remove any filters
ActiveSheet.AutoFilterMode = False
With Chk
'~~> Filter,
.AutoFilter Field:=3, Criteria1:="NO"
'~~> Offset(to exclude headers)
Set FltrdRange = .Offset(1, 0).SpecialCells(xlCellTypeVisible)
'~~> Remove any filters
ActiveSheet.AutoFilterMode = False
'~~> Add Temp Sheet
Set TmpSht = Sheets.Add
ActiveSheet.Name = "Alistair_Weir"
'~~> Copy required rows to temp sheet
TSLastRow = 1
For Each aCell In FltrdRange
If aCell.Column = 8 And _
Len(Trim(.Range("B" & aCell.Row).Value)) <> 0 And _
Len(Trim(aCell.Value)) <> 0 Then
WS1.Rows(aCell.Row).Copy TmpSht.Rows(TSLastRow)
TSLastRow = TSLastRow + 1
End If
Next
End With
End With
With TmpSht
'~~> Sort Data
.Columns("A:H").Sort Key1:=.Range("H1"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
'~~> Create the message
For i = 1 To TSLastRow - 1
msg = msg & vbNewLine & _
"Request for contractor code " & .Range("B" & i).Value & _
" dispensing month " & .Range("A" & i).Value & _
" has been in the cupboard for " & _
DateDiff("d", .Range("H" & i).Value, Date) & " days."
Next
'~~> Delete the temp sheet
Application.DisplayAlerts = False
.Delete
Application.DisplayAlerts = True
End With
'~~> Show message
MsgBox msg
Reenter:
Application.ScreenUpdating = True
Exit Sub
WhatWentWrong:
MsgBox Err.Description
Resume Reenter
End Sub

Load CSV data into a specific excel spreadsheet in a workbook

I'm having issues loading CSV data into the current active workbook, but in a separate sheet.
Right now I'm downloading temporary data into this separate (hidden) sheet, and will refer to it in other sheets. The spreadsheet is approx 4MB, and is updated daily.
How can I get VBScript to load this CSV into a staticly named sheet that would be cleared prior to loading?
URLDownloadToFile 0, fileURL, "%tmp%\tmpExchDBData.csv", 0, 0
Dim dbSheet As Worksheet Dim targetSheet As Worksheet
Workbooks.Open Filename:="%tmp%\tmpExchDBData.csv", _
Format:=2 ' use comma delimiters
Set dbSheet = ActiveSheet
Set targetSheet = Workbooks("Book1").Sheets(3) ' wherever you want to move it to
dbSheet.Move After:=targetSheet ' dbSheet is now in your workbook.
' Hide it. Set dbSheet = ActiveSheet dbSheet.Visible = xlSheetHidden
Importing CSV, especially regularly importing the same CSV file, can be done by defining it as a data source. Select the sheet you want it in, Data Ribbon, From Text.
Once defined you have spectacularly useful options in the connection properties such as "Refresh data when opening" or "Refresh every x minutes".
I've had a similar issue. If it helps, here's the piece of code I ended up with:
Sub Atualizar_B_BR_QSA_IC()
Application.ScreenUpdating = False 'speed up macro execution
Application.EnableEvents = False 'turn off other macros for now
Application.DisplayAlerts = False 'turn off system messages for now
'Atualizar base B_BR_QSA_IC
Dim base_1 As Workbook
Dim plan_1 As Worksheet
Dim nome_arquivo_1 As String
Dim destino_1 As Worksheet
nome_arquivo_1 = Application.ActiveWorkbook.Path & "\BR_QSA_Report_CC.csv"
Set destino_1 = ThisWorkbook.Worksheets("B_BR_QSA_IC")
Set base_1 = Workbooks.Open(Filename:=nome_arquivo_1, Local:=True)
Set plan_1 = base_1.Worksheets(1)
'Limpar a última linha, que é uma linha de totais e não queremos usar
plan_1.Cells(Rows.Count, "A").End(xlUp).EntireRow.Delete
'Caso o excel já não entenda corretamente na abertura, vamos fazer Texto para Colunas do csv
plan_1.Range("A1:A" & plan_1.Cells(Rows.Count, "A").End(xlUp).Row).TextToColumns _
Destination:=Range("A1"), DataType:=xlDelimited, Comma:=True, FieldInfo:=Array(1, 4)
'Agora vamos copiar a base para o arquivo Master (após limpá-lo) e fechar a base sem salvar
destino_1.Range("B2:T" & destino_1.Cells(Rows.Count, "B").End(xlUp).Row).Clear
plan_1.Range("A3:S" & plan_1.Cells(Rows.Count, "A").End(xlUp).Row).Copy
destino_1.Range("B2").PasteSpecial xlPasteValuesAndNumberFormats
base_1.Close savechanges:=False
'Se não há fórmula nas colunas A e B após plugar a base, precisamos colocar até o tamanho da base
If IsEmpty(destino_1.Range("A" & destino_1.Cells(Rows.Count, "B").End(xlUp).Row)) Then
destino_1.Range("A2").Copy Destination:=destino_1.Range("A" & (destino_1.Cells(Rows.Count, "A").End(xlUp).Row + 1) _
& ":" & "A" & destino_1.Cells(Rows.Count, "B").End(xlUp).Row)
'Se já há, precisamos limpar até o tamanho da base
ElseIf Not IsEmpty(destino_1.Range("A" & (destino_1.Cells(Rows.Count, "B").End(xlUp).Row + 1))) Then
destino_1.Rows((destino_1.Cells(Rows.Count, "B").End(xlUp).Row + 1) & ":" & destino_1.Cells(Rows.Count, "A") _
.End(xlUp).Row).EntireRow.Delete
End If
'Maquiagem
destino_1.Cells.Font.Name = "Calibri"
destino_1.Cells.Font.Size = 8
destino_1.Rows.RowHeight = 11.25
Application.DisplayAlerts = True 'turn system alerts back on
Application.EnableEvents = True 'turn other macros back on
Application.ScreenUpdating = True 'refreshes the screen
End Sub

Resources