I have hundreds of Columns in excel that I don't need. I have a range that I want to keep.
At the minute I have
Sub DeleteClms ()
Range("A:G,L:O").Delete
End Sub
Is there anyway to make this an opposite, in other languages I would simply put a =!.
I have tried putting <> in but I dont know where/how to put it into my code?
Thanks
There is no Excel or VBA function for the Symetric Difference of the columns that I know of.
Here is a quick VBA function to get there. Usage would be DeleteAllBut Range("A:C,H:Q")
Sub DeleteAllBut(rngToKeep As Range)
Dim ws As Worksheet
Dim rngToDelete As Range
Dim rngColi As Range
'Number of columns used in worksheet
Set ws = rngToKeep.Parent
iCols = ws.UsedRange.Columns.Count
FirstOne = True
For i = 1 To iCols
Set rngColi = Range("A:A").Offset(0, i - 1)
If Intersect(rngToKeep, rngColi) Is Nothing Then
If FirstOne Then
Set rngToDelete = rngColi
FirstOne = False
Else
Set rngToDelete = Union(rngColi, rngToDelete)
End If
End If
Next i
Debug.Print rngToDelete.Address & " was deleted from " & ws.Name
rngToDelete.Delete
End Sub
Related
I have over 20 sheets with VBA codes that performs calculations realtime and simultaneously. All the calculations on each sheet are working fine except some COUNTIF and FIND ADDRESS function whereby VBA ignores running them on every other sheet unless I'm active on that sheet, then it works.
I have tried several methods and this one works by activating all the sheets from another sub
Worksheets("Sheet2").activate
Worksheets("Sheet3").activate
Worksheets("Sheet4").activate
By doing this, the COUNTIF and FIND ADDRESS functions works on all sheets however, it's flickering through all of the sheets. I was also able to get it to stop on one sheet by adding (Worksheets("Sheet1").activate) at the end of the last sub. This doesn't fix the issue as I am unable to check any other sheet. I also tried
Application.ScreenUpdating = False 'At the beginning of the sub
Application.ScreenUpdating = True 'At the end of the sub
No luck. Tried wrapping each code in the vba around
Dim ws As Worksheets
ws.activate
Doesn't fix the issue. How can I activate all sheets without flickering through them? If activating them all at once can't fix the issue, is there another way? Thank you
Here is the sample of the code -
psup = "Generated" & " " & lBar
If Abs(sp2) = 0 Then
If Cells.Find(psup).Offset(-8, 0).Value > 3 Or Cells(b + 1, h).Offset(-8, 0).Value > 3 Then
Call allNewYes
'Cells(b - 7, h).Value = Cells(b - 7, h).Value + 4
sp2 = 1
End If
End If
'1.Get Position - Generated
If Application.WorksheetFunction.CountIf(ActiveSheet.Cells, psup) > 2 Then
sp6 = Application.WorksheetFunction.CountIf(ActiveSheet.Cells, psup) - 1
Call spLocation
Else
If Application.WorksheetFunction.CountIf(ActiveSheet.Cells, psup) > 0 Then
sp5 = Cells.Find(psup).Address
End If
End If
Sub allNewYes()
Dim locazion As String
Dim FindValue As String
FindValue = psup
Dim FindRng As Range
Set FindRng = Cells.Find(What:=FindValue)
Dim FirstCell As String
FirstCell = FindRng.Address
Do
locazion = FindRng.Address
Range(locazion).Offset(-8, 0).Value = Abs(Range(locazion).Offset(-8, 0).Value) + 4
Set FindRng = Cells.FindNext(FindRng)
Loop While FirstCell <> FindRng.Address
End Sub
Here is a mock-up of how you perform actions on multiple worksheets, without selecting or activating them - using part of your code as an example. I wasn't sure how you create FindValue - so you'd have to do that part yourself.
Sub perform_actions_on_all_sheets()
Dim wb As Workbook, ws As Worksheet, FindRng As Range, FirstCell As String
FindValue = 5 'change this to something appropriate
Set wb = ThisWorkbook
For Each ws In wb.Sheets
If ws.Name <> "ExcludeThisWorksheetName" Then
'do stuff to ws, e.g.
Set FindRng = ws.Cells.Find(What:=FindValue)
If Not (FindRng Is Nothing) Then
FirstCell = FindRng.Address
Do
FindRng.Offset(-8, 0).Value = Abs(FindRng.Offset(-8, 0).Value) + 4
Set FindRng = ws.Cells.Find(FindValue, LookIn:=xlValues, LookAt:=xlWhole)
Loop While FirstCell <> FindRng.Address
End If
End If
Next
End Sub
The If ws.Name <> "ExcludeThisWorksheetName" Then ... End If is optional - this is usually required if you want to run the script on every tab except one.
For anyone experiencing similar issues, by removing (ActiveSheet.Cells) in my code fixed the issue
I am trying to develop a custom function to check if the data in a listobject is filtered.
Public Function TestFiltered() As Boolean
Dim rngFilter As Range
Dim r As Long, f As Long
Set rngFilter = ActiveSheet.AutoFilter.Range
r = rngFilter.Rows.Count
f = rngFilter.SpecialCells(xlCellTypeVisible).Count
If r > f Then TestFiltered = True
End Function
However I am getting an error "Object variable not set" in Set rngFilter = ActiveSheet.AutoFilter.Range
All of my sheets will only have one listobject, but perhaps it is safer to somehow change the function to apply the range for the first listobject found in the activesheet?
The idea of multiplying the columns and the rows and comparing them with filterArea.SpecialCells(xlCellTypeVisible).Count is rather interesting. This is what I managed to build on it:
Public Function TestFiltered() As Boolean
Dim filterArea As Range
Dim rowsCount As Long, cellsCount As Long, columnsCount As Long
Set filterArea = ActiveSheet.ListObjects(1).Range
rowsCount = filterArea.rows.Count
columnsCount = filterArea.Columns.Count
cellsCount = filterArea.SpecialCells(xlCellTypeVisible).Count
If (rowsCount * columnsCount) > cellsCount Then
TestFiltered = True
End If
End Function
Here's another approach that tests a specific listobject. It first uses the ShowAutoFilter property of the ListObject to determine whether the AutoFilter is dislayed. If so, it then uses the FilterMode property of the AutoFilter object to determine whether it's in filter mode.
Option Explicit
Sub test()
Dim listObj As ListObject
Set listObj = Worksheets("Sheet2").ListObjects("Table1") 'change the sheet and table names accordingly
If IsListobjectFiltered(listObj) Then
MsgBox listObj.Name & " is filtered", vbInformation
Else
MsgBox listObj.Name & " is not filtered.", vbInformation
End If
End Sub
Function IsListobjectFiltered(ByVal listObj As ListObject) As Boolean
If listObj.ShowAutoFilter Then
If listObj.AutoFilter.FilterMode Then
IsListobjectFiltered = True
Exit Function
End If
End If
IsListobjectFiltered = False
End Function
Try along these lines
Dim i As Long
Dim isFiltered As Boolean
' test if AutoFilter has been turned on in the active sheet
If ActiveSheet.AutoFilterMode Then
' loop through the filters of the AutoFilter
With ActiveSheet.AutoFilter.Filters
For i = 1 To .Count
If .Item(i).On Then
isFiltered = True
Exit For
End If
Next i
End With
End If
This will also work if you are using Tables in Excel. I am using something like this in an If-Then statement to see if the number of rows in the first column matches the number of visible cells in the first column:
Dim tbl As ListObject
Set tbl = ActiveSheet.ListObjects("Table1")
If tbl.ListColumns(1).DataBodyRange.Rows.Count <> tbl.ListColumns(1).DataBodyRange.Rows.SpecialCells(xlCellTypeVisible).Count Then
'Do something if True
End If
I have three different tables that sends data too another tables in a different sheets when I push a button. However when one or two of the tables are empty I want excel to ignore the empty table/s
I've tried using this code from here but it only adds a new blank row
If WorksheetFunction.CountA(Range("Storningar")) = 1 Then
tblStorning.DataBodyRange.Copy
TargetTblLastRow.Range.PasteSpecial xlPasteValues
End If
Tried this one also but same result:
If tblStorning.DataBodyRange Is Nothing Then
'Do something if there is no data
Else
tblStorning.DataBodyRange.Copy
TargetTblLastRow.Range.PasteSpecial xlPasteValues 'Do something if there is data
End If
This is what the sub looks for one of the tables that sends data from table to the other one without the IF statements
Sub SkickaStorningar()
Dim tblStorning As ListObject
Dim tblStorningOuput As ListObject
Dim TargetTblLastRow As Variant
Set tblStorning = Worksheets("Rapport").ListObjects("Storningar")
Set tblStorningOutput = Worksheets("Storningar").ListObjects("StorningsTabell")
Set TargetTblLastRow = tblStorningOutput.ListRows.Add
tblStorning.DataBodyRange.Copy
TargetTblLastRow.Range.PasteSpecial xlPasteValues
End Sub
When I push the button to send the tables I just want to send the tables that has data and ignore the ones that dont
Thanks for any help
Edit with new info:
You probably have something like this:
Sub SkickaStorningar()
Dim tblStorning As ListObject
Dim tblStorningOuput As ListObject
Dim TargetTblLastRow As Variant
Set tblStorning = Worksheets("Rapport").ListObjects("Storningar")
Set tblStorningOutput = Worksheets("Storningar").ListObjects("StorningsTabell")
Set TargetTblLastRow = tblStorningOutput.ListRows.Add ' Always adds a row
If tblStorning.ListRows.Count > 0 Then
tblStorning.DataBodyRange.Copy
TargetTblLastRow.Range.PasteSpecial xlPasteValues
End If
End Sub
Every time you run this macro, you're adding a new blank row in your target table. You should only add a row if the if statement evaluates TRUE. Like this:
Sub SkickaStorningar()
Dim tblStorning As ListObject
Dim tblStorningOuput As ListObject
Dim TargetTblLastRow As Variant
Set tblStorning = Worksheets("Rapport").ListObjects("Storningar")
Set tblStorningOutput = Worksheets("Storningar").ListObjects("StorningsTabell")
If tblStorning.ListRows.Count > 0 Then
Set TargetTblLastRow = tblStorningOutput.ListRows.Add ' Only execute ListRows.Add if you want to add a row
tblStorning.DataBodyRange.Copy
TargetTblLastRow.Range.PasteSpecial xlPasteValues
End If
End Sub
Try:
Option Explicit
Sub test()
Dim table As ListObject
With ThisWorkbook.Worksheets("Sheet1") '<- Change sheet name if needed
Set table = .ListObjects("tblTest") '<- Change table name
If Not table.DataBodyRange Is Nothing Then
'Code
End If
End With
End Sub
I have a macro written that clears contents of the active cell row then calls a module to shift the remaining rows up. I am experiencing a long wait time for the macro to finish running. Not sure if this could be written better to execute quicker. The first module is called when a user clicks "Remove Client" on a User Form. Any help would be appreciated. Thank you!
'Called when user clicks Remove Client on User Form
Sub letsgo()
Dim ws As Worksheet
Dim wb As Workbook
Set wb = ThisWorkbook
Set ws = wb.Sheets("contactunder")
ws.Range("C" & ActiveCell.Row & ":BJ" & ActiveCell.Row).ClearContents
Call shiftmeup
End Sub
Sub shiftmeup()
Dim ws As Worksheet
Dim wb As Workbook
Set wb = ThisWorkbook
Set ws = wb.Sheets("contactunder") '/// The underhood of my contacts
With ws.Range("D11:BJ392")
For i = .Rows.Count To 1 Step -1
If IsEmpty(.Cells(i, 1)) Then .Rows(i).Delete Shift:=xlUp
Next
End With
End Sub
Why not change this line:
ws.Range("C" & ActiveCell.Row & ":BJ" & ActiveCell.Row).ClearContents
To this:
ws.Range("C" & ActiveCell.Row & "BJ" & ActiveCell.Row).EntireRow.Delete
This way you can avoid your second sub all together (or keep this as an occasional cleaner rather run it every time you simply need to delete 1 row.)
If you really do need both subs, a common first step for efficiency is to disable screen updating before entering your loop with Application.ScreenUpdating = False and then re-activate it when your loop ends by changing False to True.
This is the followup to urdearboy's answer...
The issue was in your second function and the static range used. You were deleting all the rows at the end, past your data (up to ~380 extra delete row calls). To fix it you should do two things
Only loop to the last row of data
Limit calls to the front end; put all the cells you want to delete into one range and delete it once
Sub ShiftMeUp()
Dim wb As Workbook
Dim ws As Worksheet
Dim DeleteRowRange As Range
Set wb = ThisWorkbook
Set ws = wb.Sheets("contactunder") '/// The underhood of my contacts
For i = 1 To GetLastRow(1, ws)
If IsEmpty(ws.Cells(i, 1)) Then Set DeleteRowRange = MakeUnion(ws.Rows(i), DeleteRowRange)
Next
If Not DeleteRowRange Is Nothing Then DeleteRowRange.EntireRow.Delete Shift:=xlUp
End Sub
I used 2 on my commonly used functions to keep the code clean...
MakeUnion
Public Function MakeUnion(Arg1 As Range, Arg2 As Range) As Range
If Arg1 Is Nothing Then
Set MakeUnion = Arg2
ElseIf Arg2 Is Nothing Then
Set MakeUnion = Arg1
Else
Set MakeUnion = Union(Arg1, Arg2)
End If
End Function
GetLastRow
Public Function GetLastRow(Optional Col As Integer = 1, Optional Sheet As Excel.Worksheet) As Long
If Sheet Is Nothing Then Set Sheet = Application.ActiveSheet
GetLastRow = Sheet.Cells(Sheet.Rows.Count, Col).End(xlUp).Row
End Function
I have attempted to add functionality to an excel add-in ave been developing which trims the leading spaces at the end of used cells, and maybe even parse the text, The reason I need to do this is simply to have it turn into a hyperlink which I have already working but that parts fine.
This is what I have attempted so far, I have it trimming the active.worksheet am on which is fine but I can't figure out how to:
Trim Every cell being used across the whole workbook.
And also parse the text if possible
This is my attempt at Trimming the entire workbook, Its something simple I just know it, I just cant figure it out:
Sub DoTrim(Wb As Workbook)
Dim cell As Range
Dim str As String
Dim nAscii As Integer
Dim wsh As Worksheet
For Each wsh In Worksheets
With wsh.UsedRange
For Each cell In ActiveSheet.UsedRange
str = Trim(cell)
If Len(str) > 0 Then
nAscii = Asc(Left(str, 1))
If nAscii < 33 Or nAscii = 160 Then
If Len(str) > 1 Then
str = Right(str, Len(str) - 1)
Else
str = ""
End If
End If
End If
cell = str
Next cell
End With
Next wsh
End Sub
Any advice would be welcome am fairly new to this Language so sorry if I sound like a complete Newb!
TL;DR Trims cells only worksheet am on, needs to run across whole workbook I cant figure out how to iterate it across the whole thing.
EDIT: Is that also a quicker way of trimming these cells, the spreadsheets that are created for whom am designing this are massive and takes a while to trim the cells at times
Try this
Sub DoTrim(Wb As Workbook)
Dim aCell As Range
Dim wsh As Worksheet
'~~> If you are using it in an Add-In, it is advisable
'~~> to keep the user posted :)
Application.StatusBar = "Processing Worksheets... Please do not disturb..."
DoEvents
Application.ScreenUpdating = False
For Each wsh In Wb.Worksheets
With wsh
Application.StatusBar = "Processing Worksheet " & _
.Name & ". Please do not disturb..."
DoEvents
For Each aCell In .UsedRange
If Not aCell.Value = "" And aCell.HasFormula = False Then
With aCell
.Value = Replace(.Value, Chr(160), "")
.Value = Application.WorksheetFunction.Clean(.Value)
.Value = Trim(.Value)
End With
End If
Next aCell
End With
Next wsh
Application.ScreenUpdating = True
Application.StatusBar = "Done"
End Sub
I agree with Siddarth:
For Each cell In ActiveSheet.UsedRange
Should be:
For Each cell In wsh.UsedRange
I would have thought you should be able to remove with 'With wsh.UsedRange' statement around the loop as well.
As you are passing in a WorkBook reference, perhaps you should consider changin your outer For loop from:
For Each wsh In Worksheets
to:
For Each wsh In Wb.Worksheets