I created this macro to delete every empty column in active workbook. However it does not work on each sheet and only on an active one.
Please let me know your ideas what can be done to make macro work properly and loop through all the worksheets, not only the active one.
Sub DeleteBlankColumns()
Dim LastColumn As Long
Dim r As Long
Dim Counter As Long
Dim Current As Worksheet
Application.ScreenUpdating = False
For Each Current In Worksheets
LastColumn = Current.UsedRange.Columns.Count + Current.UsedRange.Columns(1).Column - 1
For r = LastColumn To 1 Step -1
If Application.WorksheetFunction.CountA(Columns(r)) = 0 Then
Current.Columns(r).Delete
Counter = Counter + 1
End If
Next r
Next
Application.ScreenUpdating = True
MsgBox "Deleted " & Counter & " empty columns."
End Sub
Try this:
Option Explicit
Sub DeleteBlankColumns()
Dim LastColumn As Long
Dim r As Long
Dim Counter As Long
Dim Current As Worksheet
Application.ScreenUpdating = False
For Each Current In Worksheets
With Current
LastColumn = .UsedRange.Columns.Count + .UsedRange.Columns(1).Column - 1
For r = LastColumn To 1 Step -1
If Application.WorksheetFunction.CountA(.Columns(r)) = 0 Then
.Columns(r).Delete
Counter = Counter + 1
End If
Next r
End With
Next
Application.ScreenUpdating = True
MsgBox "Deleted " & Counter & " empty columns."
End Sub
Related
How to add a worksheet in excel with VBA after a specific sheetname held by variable?
I tried:
Set sh = wb.Worksheets.Add(After:=wb.Sheets(wsPattern & CStr(n)))
The previous incremented sheetname is stored in "wsPattern & CStr(n)", The new sheetname increments up properly from another statement and variable, but the add after fails with the above syntax. I'm getting an out of range error at this line.
The code fully executes using this statement, but adds any newly created sheets from any given series at the end of all sheets:
Set sh = wb.Worksheets.Add(After:=wb.Sheets(wb.Sheets.Count))
As the workbook has 4 series of sheet names now (e.g. Test1, logistic1, Equip1, Veh1, etc.) that are incremented up as they are added, the next incremented sheet for a given series needs to be added to the end of that sheet name series (Equip2 should be after Equip1) and not at the end of all sheets.
Sub CreaIncWkshtEquip()
Const wsPattern As String = "Equip "
Dim wb As Workbook: Set wb = ThisWorkbook
Dim arr() As Long: ReDim arr(1 To wb.Sheets.Count)
Dim wsLen As Long: wsLen = Len(wsPattern)
Dim sh As Object
Dim cValue As Variant
Dim shName As String
Dim n As Long
For Each sh In wb.Sheets
shName = sh.Name
If StrComp(Left(shName, wsLen), wsPattern, vbTextCompare) = 0 Then
cValue = Right(shName, Len(shName) - wsLen)
If IsNumeric(cValue) Then
n = n + 1
arr(n) = CLng(cValue)
End If
End If
Next sh
If n = 0 Then
n = 1
Else
ReDim Preserve arr(1 To n)
For n = 1 To n
If IsError(Application.Match(n, arr, 0)) Then
Exit For
End If
Next n
End If
'adds to very end of workbook
'Set sh = wb.Worksheets.Add(After:=wb.Sheets(wb.Sheets.Count))
'Test-Add After Last Incremented Sheet-
Set sh = wb.Worksheets.Add(After:=wb.Sheets(wsPattern & CStr(n)))
sh.Name = wsPattern & CStr(n)
End Sub
Create a function
Sub Demo()
Dim s
s = AddSheet("SeriesName")
MsgBox s & " Added"
End Sub
Function AddSheet(sSeries As String) As String
Dim ws, s As String, i As Long, n As Long
With ThisWorkbook
' find last in series
For n = .Sheets.Count To 1 Step -1
s = .Sheets(n).Name
If s Like sSeries & "[1-9]*" Then
i = Mid(s, Len(sSeries) + 1)
Exit For
End If
Next
' not found add to end
If i = 0 Then
n = .Sheets.Count
End If
' increment series
s = sSeries & i + 1
.Sheets.Add after:=.Sheets(n)
.Sheets(n + 1).Name = s
End With
AddSheet = s
End Function
I need to delete sheets not mentioned in the given list(Range is A7:A350).
I found this vba but the problem is it deletes all the sheets from my workbook, maybe because sheetname is in numeric. I would really appreciate any help.
Sub Deletenotinlist()
Dim i As Long
Dim cnt As Long
Dim xWb, actWs As Worksheet
Set actWs = ThisWorkbook.ActiveSheet
cnt = 0
Application.DisplayAlerts = False
For i = Sheets.Count To 1 Step -1
If Not ThisWorkbook.Sheets(i) Is actWs Then
xWb = Application.Match(Sheets(i).Name, actWs.Range("A7:A350"), 0)
If IsError(xWb) Then
ThisWorkbook.Sheets(i).Delete
cnt = cnt + 1
End If
End If
Next
Application.DisplayAlerts = True
If cnt = 0 Then
MsgBox "Not find the sheets to be seleted", vbInformation, "Kutools for Excel"
Else
MsgBox "Have deleted" & cnt & "worksheets"
End If
End Sub
I think I would do it this way.
Sub DeleteSheets()
Dim sht As Worksheet
Dim rng As Range
Set rng = Sheets("Sheet1").Range("A2:A10")
Application.DisplayAlerts = False
For Each sht In ActiveWorkbook.Worksheets
If Application.CountIf(rng, sht.Name) = 0 Then
sht.Delete
End If
Next sht
Application.DisplayAlerts = True
End Sub
What you try doing can be accomplished in many ways, but I tried adapting your code to place the missing sheets name in an array and select them at the end. If selection is convenient, you can replace Select with Delete:
Sub Deletenotinlist()
Dim i As Long, cnt As Long, xWb, actWs As Worksheet, lastR As Long, arrSh(), k As Long
Set actWs = ThisWorkbook.ActiveSheet
lastR = actWs.Range("A" & actWs.rows.count).End(xlUp).row
ReDim arrSh(ThisWorkbook.Sheets.count - 1)
cnt = 0
For i = 1 To Sheets.count
If Not ThisWorkbook.Sheets(i) Is actWs Then
xWb = Application.match(Sheets(i).Name, actWs.Range("A7:A" & lastR), 0)
If IsError(xWb) Then
arrSh(k) = CStr(ThisWorkbook.Sheets(i).Name): k = k + 1
cnt = cnt + 1
End If
End If
Next
ReDim Preserve arrSh(k - 1) 'keep only the filled array elements
Sheets(arrSh).Select 'You can replace 'Select' with 'Delete', if it returns correctly
If cnt = 0 Then
MsgBox "Not find the sheets to be seleted", vbInformation, "Kutools for Excel"
Else
MsgBox "Have deleted " & cnt & " worksheets"
End If
End Sub
It processes all existing values in column A:A, starting from the 7th row.
But I'm afraid that the range you try processing does not contain any existing sheet name...
In order to test the above supposition, please run the next test sub, which will place all existing sheets name in column B:B, starting from the 7th row. Then delete some rows and run the previous code, replacing "A" with "B" in lastR = actWs.Range("A" &... and actWs.Range("A7:A" & lastR). The code should select all missing sheets:
Sub testArraySheets()
Dim arrSh, ws As Worksheet, k As Long
ReDim arrSh(ActiveWorkbook.Sheets.count - 1)
For Each ws In ActiveWorkbook.Sheets
If Not ws Is ActiveSheet Then
arrSh(k) = ws.Name: k = k + 1
End If
Next
ActiveSheet.Range("B7").Resize(UBound(arrSh) + 1, 1).Value = Application.Transpose(arrSh)
End Sub
I would like to delete all empty columns between 2 used ranges, based on the screenshot:
However, these two used ranges may have varying column length, thus the empty columns are not always Columns D to K.
Here is my code:
Sub MyColumns()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Workbooks.Open ("BOOK2.xlsx")
Workbooks("BOOK2.xlsx").Activate
Workbooks("BOOK2.xlsx").Sheets(1).Activate
Workbooks("BOOK2.xlsx").Sheets(1).Cells(1, 4).Value = "NON-EMPTY"
Dim finalfilledcolumn As Long
finalfilledcolumn = Workbooks("BOOK2.xlsx").Sheets(1).Cells(1, Columns.Count).End(xlToLeft).Column
Dim iCol As Long
Dim i As Long
iCol = firstfilledcolumn + 1
'Loop to delete empty columns
For i = 1 To firstfilledcolumn + 1
Columns(iCol).EntireColumn.Delete
Next i
Workbooks("BOOK2.xlsx").Close SaveChanges:=True
MsgBox "DONE!"
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
However, the empty columns still remain.
Do note that the last filled column for the first used range, Place = "USA", Price = "110" and Category = "Mechanical" may not be fixed at Column C, but could go to Column D, E, etc.
Many thanks!
Please, try the next way:
Sub deleteEmptyColumn()
Dim sh As Worksheet, lastCol As Long, rngColDel As Range, i As Long
Set sh = ActiveSheet 'use here your necessary sheet, having the workbook open
'if not open, you can handle this part...
lastCol = sh.cells(1, sh.Columns.count).End(xlToLeft).column
For i = 1 To lastCol
If WorksheetFunction.CountA(sh.Columns(i)) = 0 Then
If rngColDel Is Nothing Then
Set rngColDel = sh.cells(1, i)
Else
Set rngColDel = Union(rngColDel, sh.cells(1, i))
End If
End If
Next i
If Not rngColDel Is Nothing Then rngColDel.EntireColumn.Delete
End Sub
Try this ..
Dim rng As Range, i As Long
Set rng = Workbooks("BOOK2.xlsx").Sheets(1).UsedRange
For i = rng.Columns.Count To 1 Step -1
If WorksheetFunction.CountA(rng.Columns(i)) = 0 Then
rng.Columns(i).EntireColumn.Delete
End If
Next i
I have a workbook with 10 sheets. Each sheet has about 30,000 rows with URL. I have a hand full of URLs (about 10 different URLs) that I need to keep the data. Is there a way to delete all the rows from all the worksheet if the first column (Column A - URL) does not contain one of the URL.
for example, I would like to keep we.abc.us, ss.boli.us and 3m.mark.us and delete rest of the rows from all the worksheet in the workbook.
Sub delete0rows()
Dim Worksheet As Excel.Worksheet
Dim lastRow As Long
Dim i As Integer
For Each Worksheet In Application.ThisWorkbook.Worksheets
lastRow = Worksheet.Cells(Rows.Count, 1).End(xlUp).Row
i = 1
Do While i <= lastRow
If Worksheet.Range("A" & i).Value = 0 Then
Worksheet.Rows(i).Delete i = i - 1
lastRow = lastRow - 1
End
i = i + 1
Loop
Next Worksheet
End Sub
I suggest you introduce reverse For loop using Step -1:
Sub delete0rows()
Dim Worksheet As Excel.Worksheet
Dim lastRow As Long
Dim i As Integer
For Each Worksheet In Application.ThisWorkbook.Worksheets
lastRow = Worksheet.Cells(Rows.Count, 1).End(xlUp).Row
For i = lastRow To 1 Step -1
If Worksheet.Range("A" & i).Value = 0 Then
Worksheet.Rows(i).EntireRow.Delete
End If
Next i
Next Worksheet
End Sub
I found this sub a while back. I cannot remember who the original author was or I would credit them. I did tweak it slightly to pass variables into it
The nice thing about this is you can pass multiple deletion criteria by passing a space separated string
Essentially you can give it a row to start at (in case you have headers) tell it the column to look in, the sheet that column is on and your criteria/criterion. So for example if I want it to start at row 5 checking each row below that on a sheet named 'cleanup' checking column 'D' for the words 'cat' 'dog' and 'fish' I would write
Call DelRow(5,"D","cleanup","cat dog fish")
Public Sub DelRow(DataStartRow As Long, SearchColumn As String, SheetName As String, myTextString As String)
' This macro will delete an entire row based on the presence of a predefined word or set of words.
'If that word or set of words is 'found in a cell, in a specified column, the entire row will be 'deleted
'Note the seperator is a space. To change this modify the split parameter
'EXAMPLE CALL: Call DelRow(1, "AH", "Cut Data", "DEL")
Dim X As Long
Dim Z As Long
Dim LastRow As Long
Dim FoundRowToDelete As Boolean
Dim OriginalCalculationMode As Integer
Dim RowsToDelete As Range
Dim SearchItems() As String
SearchItems = Split(myTextString)
On Error GoTo ResetCalcs
OriginalCalculationMode = Application.Calculation
Application.Calculation = xlCalculationManual
With Worksheets(SheetName)
LastRow = .Cells(.Rows.Count, SearchColumn).End(xlUp).Row
Application.StatusBar = "**** Working on the '" & SheetName & "' Sheet: Number of Rows to be scanned(" & LastRow & "). Deletion keyword " & myTextString & " ***" 'Extra line added
For X = LastRow To DataStartRow Step -1
FoundRowToDelete = False
For Z = 0 To UBound(SearchItems)
If InStr(.Cells(X, SearchColumn).Value, SearchItems(Z)) Then
FoundRowToDelete = True
Exit For
End If
Next
If FoundRowToDelete Then
If RowsToDelete Is Nothing Then
Set RowsToDelete = .Cells(X, SearchColumn)
Else
Set RowsToDelete = Union(RowsToDelete, .Cells(X, SearchColumn))
End If
If RowsToDelete.Areas.Count > 100 Then
RowsToDelete.EntireRow.Delete
Set RowsToDelete = Nothing
End If
End If
Next
End With
If Not RowsToDelete Is Nothing Then
RowsToDelete.EntireRow.Delete
End If
ResetCalcs:
Application.Calculation = OriginalCalculationMode
End Sub
I would like to export data from a consolidated sheet (DATA) to multiple sheets regarding criteria.
I have a total of 13 criteria, each criteria has to be exported in its dedicated sheet.
I'm trying to optimize this macro (only 2 criteria here) because it lag out
Sub copy()
Application.ScreenUpdating = False
Dim i As Long
Dim j As Long
Dim sh As Worksheet
Dim feuillePrincipale As Worksheet
Dim S01Sheet As Worksheet
Dim S02Sheet As Worksheet
Set feuillePrincipale = ThisWorkbook.Sheets("DATA")
Set S01Sheet = ThisWorkbook.Sheets("S01")
Set S02Sheet = ThisWorkbook.Sheets("S02")
For Each sh In ThisWorkbook.Worksheets
If sh.Name = "S01" Then
i = 2
j = 2
While Not IsEmpty(feuillePrincipale.Cells(i, 1))
If feuillePrincipale.Cells(i, 11).Value Like "S01*" Then
feuillePrincipale.Cells.Rows(i).EntireRow.copy S01Sheet.Rows(j)
j = j + 1
End If
i = i + 1
Wend
End If
If sh.Name = "S02" Then
i = 2
j = 2
While Not IsEmpty(feuillePrincipale.Cells(i, 1))
If feuillePrincipale.Cells(i, 11).Value Like "S02*" Then
feuillePrincipale.Cells.Rows(i).EntireRow.copy S02Sheet.Rows(j)
j = j + 1
End If
i = i + 1
Wend
End If
Next
Application.ScreenUpdating = True
End Sub
If you have any idea, I read I can use Advanced filter but as you guess I'm new in VBA so I'm listening any tips!
Here is the Advanced Filter method you asked for:
Public Sub Christophe()
Const FILTER_COLUMN = 11
Dim i&, rCrit As Range, rData As Range, aShts
aShts = ["SO"&row(1:13)]
Set rData = Sheets("DATA").[a1].CurrentRegion
Set rCrit = rData.Resize(2, 1).Offset(, rData.Columns.Count + 2)
rCrit(1) = rData(1, FILTER_COLUMN)
For i = 1 To UBound(aShts)
rCrit(2) = aShts(i, 1) & "*"
rData.AdvancedFilter xlFilterCopy, rCrit, Sheets(aShts(i, 1)).[a1].Resize(, rData.Columns.Count)
Next
rCrit.Clear
End Sub
The execution time should be instantaneous.
Note: this assumes that you do have 13 criteria, each starting with "SO" and that they occupy column 11 of the Data sheet. It also assumes that you already have 13 sheets named SO1... SO13 in the workbook.
UPDATE
Based on new information that the pattern of the criteria can change, please try this version instead. Note, that it assumes that the sheets already exist and that the sheet names match the criteria:
Public Sub Christophe()
Const FILTER_COLUMN = 11
Dim i&, rCrit As Range, rData As Range, aShts
aShts = Array("SO1", "SO2", "ADQ03", "LocS10")
Set rData = Sheets("DATA").[a1].CurrentRegion
Set rCrit = rData.Resize(2, 1).Offset(, rData.Columns.Count + 2)
rCrit(1) = rData(1, FILTER_COLUMN)
For i = 0 To UBound(aShts)
rCrit(2) = aShts(i) & "*"
rData.AdvancedFilter xlFilterCopy, rCrit, Sheets(aShts(i)).[a1].Resize(, rData.Columns.Count)
Next
rCrit.Clear
End Sub
Try using an array to set your criteria sheets:
Dim shArray As Variant
Dim shArrayString As String
Dim feuillePrincipale As Excel.Worksheet
Dim i As Long
Dim j As Long
Set feuillePrincipale = ThisWorkbook.Sheets("DATA")
j = 1
'// Create array and populate
shArray = Array("S01", "S02", "S03", "S04") '// add as required
'// Create string representation of array
shArrayString = "{"""
For i = LBound(shArray) To UBound(shArray)
shArrayString = shArrayString & shArray(i) & ""","""
Next
shArrayString = Left(shArrayString, Len(shArrayString) - 2) & "}"
'//Start loop
With feuillePrincipale
For i = 2 To .Cells(.Rows.Count, 1).End(xlUp).Row
If Not Evaluate("ISERROR(MATCH(" & Left(.Cells(i, 11), 3) & "," & shArrayString & ",0))") Then
.Rows(i).Copy Sheets(shArray(WorksheetFunction.Match(Left(.Cells(i, 11), 3), shArray, 0))).Cells(j, 1)
j = j + 1
End If
Next
End With
It's a bit unclear because if you follow the code you've posted - it's actually just copying and pasting data to the same sheet...
Yes, you should use an autofilter and use a special select to get only the visible cells.
If you want the loop method, you should loop through each row on sheets("DATA") and use a Select Case Statement to decide onto which sheet the data is placed.
By looping through each sheet you are adding loops that will slow it down.
Application.ScreenUpdating = False
Dim i As Long
Dim j As Long
Dim cel As Range
Dim sh As Worksheet
Dim feuillePrincipale As Worksheet
Dim S01Sheet As Worksheet
Dim S02Sheet As Worksheet
Set feuillePrincipale = ThisWorkbook.Sheets("DATA")
Set S01Sheet = ThisWorkbook.Sheets("S01")
Set S02Sheet = ThisWorkbook.Sheets("S02")
For Each cel In feuillePrincipale.Range(feuillePrincipale.Range("A1"), feuillePrincipale.Range("A1").End(xlDown))
Select Case Left(cel.offset(,10).value, 3)
Case "S01"
j = S01Sheet.Range("A" & Rows.count).End(xlUp).Offset(1).Row
feuillePrincipale.Cells.Rows(cel.Row).EntireRow.copy S01Sheet.Rows(j)
Case "S02"
j = S02Sheet.Range("A" & Rows.count).End(xlUp).Offset(1).Row
feuillePrincipale.Cells.Rows(cel.Row).EntireRow.copy S02Sheet.Rows(j)
'Case .... keep adding select statement till you get to the last condition
Case Else
End Select
Next cel
Application.ScreenUpdating = True