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
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
Using the below code to delete the repeated headers from combined into one excel but getting error.
Application.Goto DestSh.Cells(1)
' AutoFit the column width in the summary sheet.
DestSh.Columns.AutoFit
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
Dim xWs As Worksheet
Application.ScreenUpdating = False
Application.DisplayAlerts = False
For Each xWs In Application.ActiveWorkbook.Worksheets
If xWs.Name <> "Combined Sheet" Then
xWs.Delete
End If
Next
Application.DisplayAlerts = True
Application.ScreenUpdating = True
Dim lstRow As Integer, ws As Worksheet
Set ws = ThisWorkbook.Sheets("Combined Sheet")
With ws
lstRow = .Cells(rows.Count, "B").End(xlUp).Row ' Or "C" or "A" depends
.Range("A1:E" & lstRow).SpecialCells(xlCellTypeBlanks).EntireRow.Delete ERROR GETTING HERE
End With
enter image description here
Please add "on error resume next" before using SpecialCells method and after using use "on error GoTo 0"
.SpecialCells(xlCellTypeBlanks)
This expression gives you every blank cell in a Range. Rows that you are going to delete includes non-blank cells also, so vba will not delete them.
You can try a RemoveDuplicates method like:
.Range("A1:E" & lstRow).RemoveDuplicates Columns:=Array(1, 2, 3, 4, 5), Header :=xlNo
It can be not safe to use the method, but for your task it's may be Ok.
This sub is a safe variant to delete your headers. you can call the sub by the Call statement, and don't forget to set your header address.
Call removeHeaders()
Sub removeHeaders()
Dim hdrRangeAdr As String
Dim l, frstRow, lstRow, offsetRow As Long
Dim counter, row1, row2 As Integer
Dim item As Variant
Dim hdrRng, tRng As Range
Dim ws As Worksheet
' setting of the first header address
hdrRangeAdr = "A1:O1"
Set ws = ThisWorkbook.Sheets("Combined Sheet")
' setting of the header range
Set hdrRng = ws.Range(hdrRangeAdr)
hdrRowsQty = hdrRng.Rows.Count
frstRow = hdrRng.Row
lstRow = hdrRng.Parent.UsedRange.Rows.Count + frstRow
'checking row by row
For l = 1 To lstRow - frstRow
offsetRow = l + hdrRowsQty - 1
counter = 0
' compare row/rows value with the header
For Each item In hdrRng.Cells
If item = item.Offset(offsetRow, 0) Then
counter = counter + 1
End If
Next
' if they are equial then delete rows
If counter = hdrRng.Count Then
row1 = frstRow + offsetRow
row2 = row1 + hdrRowsQty - 1
ws.Rows(row1 & ":" & row2).Delete Shift:=xlUp
'reseting values as rows qty reduced
l = 1
lstRow = hdrRng.Parent.UsedRange.Rows.Count + frstRow
End If
Next
Set ws = Nothing
Set hdrRng = Nothing
End Sub
Good luck
I have 5 different Sub declarations that all pretty much do the same thing. The only part that differs are the the worksheet variants (each Sub uses 2 specific worksheets).
What I'm trying to do is condense the 5 different Subs into one piece.
The below code is an example of one of my Subs (note the code below is only change throughout the Subs)
Only code that changes in the below group1 Sub.
Set ws = wb.Worksheets("A")
Set addWS = wb.Worksheets("A add")
Code for one of the Subs
' -- Combines table1 and table2 -- '
Sub group1()
Dim wb As Workbook
Dim ws As Worksheet
Dim addWS As Worksheet
Dim counter As Long
Dim counterAdd As Long 'counter for additional trades
Set wb = Workbooks("MASTER.xlsm")
Set ws = wb.Worksheets("A")
Set addWS = wb.Worksheets("A add")
ws.Activate 'activate sheet
' Checks to see if there is only 1 row or is empty
If IsEmpty(ws.Range("A11").Value) = True Then
Exit Sub
End If
If IsEmpty(ws.Range("A12").Value) = True And IsEmpty(ws.Range("A11").Value) = False Then
counter = 1
Else
counter = ws.Range("A11", Range("A11").End(xlDown)).Rows.count
End If
addWS.Activate 'activate additional sheet
' Checks to see if there is only 1 row or is empty
If IsEmpty(addWS.Range("A11").Value) = True Then
Exit Sub
End If
If IsEmpty(addWS.Range("A12").Value) = True And IsEmpty(addWS.Range("A11").Value) = False Then
counterAdd = 1
Else
counterAdd = addWS.Range("A11", Range("A11").End(xlDown)).Rows.count
End If
' Copy / paste additional trades
addWS.Range("A11:AB" & counterAdd + 10).Copy
ws.Activate
ws.Range("A" & counter + 11).PasteSpecial xlPasteAll
End Sub
In the below code I attempted to make this into one Sub with with 2 For loops, however it would get stuck in the second loop. Is there a way that I could loop through two things at once?
' -- Combines table1 and table2 -- '
Sub group()
Dim wb As Workbook
Dim ws As Worksheet
Dim wsAdd As Worksheet
Dim counter As Long
Dim counterAdd As Long 'counter for additional trades
Dim WSArray As Variant
Dim WSArrayAdd As Variant
Set wb = Workbooks("MASTER.xlsm")
WSArray = Array("A", "B", "C", "D", "E")
WSArrayAdd = Array("A add", "B add", "C add", "D add", "E add")
'Loop through WSArray sheets
For Each currentWS In WSArray
Set ws = wb.Worksheets(currentWS)
ws.Activate
' Checks to see if there is only 1 row or is empty
If IsEmpty(ws.Range("A11").Value) = True Then
' do nothing
End If
If IsEmpty(ws.Range("A12").Value) = True And IsEmpty(ws.Range("A11").Value) = False Then
counter = 1
Else
counter = ws.Range("A11", Range("A11").End(xlDown)).Rows.count
End If
For Each currentAddWS In WSArrayAdd
Set wsAdd = wb.Worksheets(currentAddWS)
wsAdd.Activate 'activate additional sheet
' Checks to see if there is only 1 row or is empty
If IsEmpty(wsAdd.Range("A11").Value) = True Then
' do nothing
End If
If IsEmpty(wsAdd.Range("A12").Value) = True And IsEmpty(wsAdd.Range("A11").Value) = False Then
counterAdd = 1
Else
counterAdd = wsAdd.Range("A11", Range("A11").End(xlDown)).Rows.count
End If
' Copy / paste additional trades
wsAdd.Range("A11:AB" & counterAdd + 10).Copy
ws.Activate
ws.Range("A" & counter + 11).PasteSpecial xlPasteAll
Next currentAddWS
Next currentWS
End Sub
I was able to solve this in the code below. This code loops through a series of 10 sheets (each sheet has a corresponding sheet) and combines the tables to one main sheet.
' -- Combines additional trades table with main table -- '
Sub groupTables()
Dim wb As Workbook
Dim ws As Worksheet
Dim wsAdd As Worksheet
Dim counter As Long
Dim counterAdd As Long 'counter for additional trades
Dim WSArray As Variant
Dim WSArrayAdd As Variant
Dim i As Long
Set wb = Workbooks("MASTER.xlsm")
WSArray = Array("1", "2", "3", "4", "5")
'Loop through WSArray sheets
For Each currentWS In WSArray
Set ws = wb.Worksheets(currentWS)
Set wsAdd = wb.Worksheets(WSArray(i) & " add")
ws.Activate
' COUNTS ROWS IN TRADE SHEET
' Checks to see if there is only 1 row or is empty
If IsEmpty(ws.Range("A11").Value) = True Then
counter = 0 'no trades
ElseIf IsEmpty(ws.Range("A12").Value) = True And IsEmpty(ws.Range("A11").Value) = False Then
counter = 1
Else
counter = ws.Range("A11", Range("A11").End(xlDown)).Rows.count
End If
wsAdd.Activate
' COUNTS ROWS IN ADDITIONAL TRADE SHEET
' Checks to see if there is only 1 row or is empty
If IsEmpty(wsAdd.Range("A11").Value) = True Then
counterAdd = 0 'no trades
ElseIf IsEmpty(wsAdd.Range("A12").Value) = True And IsEmpty(wsAdd.Range("A11").Value) = False Then
counterAdd = 1
Else
counterAdd = wsAdd.Range("A11", Range("A11").End(xlDown)).Rows.count
End If
'Copy Additional trades
If counterAdd > 0 Then
wsAdd.Range("A11:AB" & counterAdd + 10).Copy 'Copy additional trades table
ws.Activate
ws.Range("A" & counter + 11).PasteSpecial xlPasteAll ' Paste additional trades to main table
End If
i = i + 1 'iterate
Next currentWS
End Sub
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
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