In the below script, it scans a sheet and will pull values, deleting ones that dont meet the set criteria in column "M". I can get it to work if I make the criteria fixed (in the below "MIGS Unavailable"), but if I try to refer it back to a cell (AI1) as the criteria, it either pulls every record or pulls none.
Your help please in allowing it to see the value in the cell as the criteria in the script!
Sub QuickCombine_MIGS()
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim rng1 As Range
Dim strShts()
Dim strWs As Variant
Dim lngCalc As Long
With Application
.ScreenUpdating = False
lngCalc = .Calculation
.Calculation = xlCalculationManual
End With
Set ws1 = Sheets("MIGS-Datasheet")
ws1.UsedRange.Cells.Clear
strsub = Sheets("MIGS").Range("AI2").Value
strsub2 = Sheets("MIGS").Range("AI1").Value
strShts = Array(strsub)
For Each strWs In strShts
On Error Resume Next
Set ws2 = Sheets(strWs)
On Error GoTo 0
If Not ws2 Is Nothing Then
Set rng1 = ws2.Range(ws2.[v8], ws2.Cells(Rows.Count, "v").End(xlUp))
rng1.EntireRow.Copy ws1.Cells(ws1.Cells(Rows.Count, "v").End(xlUp).Offset(1, 0).Row, "A")
End If
Set ws2 = Nothing
Next
With ws1
.[v1] = "dummy"
.Columns("M").AutoFilter Field:=1, Criteria1:="<>MIGS Unavailable"
.Rows.Delete
.Rows("1").Insert
End With
With Application
.ScreenUpdating = True
.Calculation = lngCalc
End With
End Sub
Related
I have a multidimensional power pivot table in sheet "Template2" created by a data model. I want VBA which circles through the slicer "Slicer_Sublot_code" and for each selection a new sheet to be created named after the slicer's selected item and the filtered pivot table to be pasted in it maintaining only values and format.
So far I have managed to create the empty sheets named by the slicer's items (the VBA reads the names from a range F2:F10 instead of taking them from the slicer which would be ideal):
Sub AddSheets()
Dim xRg As Excel.Range
Dim wSh As Excel.Worksheet
Dim wBk As Excel.Workbook
Set wSh = ActiveSheet
Set wBk = ActiveWorkbook
Application.ScreenUpdating = False
For Each xRg In wSh.Range("F2:F10")
With wBk
.Sheets.Add after:=.Sheets(.Sheets.Count)
On Error Resume Next
ActiveSheet.Name = xRg.Value
If Err.Number = 1004 Then
Debug.Print xRg.Value & " already used as a sheet name"
End If
On Error GoTo 0
End With
Next xRg
Application.ScreenUpdating = True
End Sub
I have also managed to do the copy/paste of the pivot table (keeping values and format) on a new sheet but the name is pre-defined "Report":
Sub PivotTablePasteSpecial()
Dim SourcePivottable As PivotTable
Dim DestinationRange As Range
Dim aCell As Range
Application.Calculation = xlCalculationManual
Application.DisplayStatusBar = False
Application.EnableEvents = False
Application.ScreenUpdating = False
Set SourcePivottable = Worksheets("Template2").PivotTables(1)
Set DestinationRange = Worksheets("Report").Range("A1")
' Copy TableRange1
SourcePivottable.TableRange1.Copy
With DestinationRange.Offset( _
SourcePivottable.TableRange1.Row - SourcePivottable.TableRange2.Row, 0)
.PasteSpecial Paste:=xlPasteValues
.PasteSpecial Paste:=xlPasteFormats
.PasteSpecial Paste:=xlPasteColumnWidths
End With
' Copy everything above TableRange1 cell-by-cell
For Each aCell In SourcePivottable.TableRange2.Cells
If Not Intersect(aCell, SourcePivottable.TableRange1) Is Nothing Then Exit For
aCell.Copy
With DestinationRange.Offset( _
aCell.Row - SourcePivottable.TableRange2.Row, _
aCell.Column - SourcePivottable.TableRange2.Column)
.PasteSpecial Paste:=xlPasteValues
.PasteSpecial Paste:=xlPasteFormats
End With
Next aCell
Application.Calculation = xlCalculationAutomatic
Application.DisplayStatusBar = True
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
How can I combine the 2 in order to achieve the desired outcome described in the first paragraph?
I currently have code were I have a file of data with unique businesses, the vba that I have programmed removes all other businesses but one. I have noticed that the file that I have worked on has legacy data below the rows filled with data I need and I need to remove these to make the file smaller.
Sub ConstructionTools()
Dim ARange As Range
Dim DRange As Range
Dim ws As Worksheet
Dim wsB As Worksheet
Dim filename As String
Set ws = Sheets("Data")
Set wsB = Sheets("Macro")
Set DRange = Nothing
Application.DisplayAlerts = False
Application.ScreenUpdating = False
For Each ARange In ws.Range("L1:L28000").Rows
If ARange(1).Value = "BUILDING CONSTRUCTION" Or ARange(1).Value = "CONSTRUCTION SERVICES" Or ARange(1).Value = "HEAVY & HIGHWAY" Or ARange(1).Value = "HEAVY CIVIL - SPS" Then
If DRange Is Nothing Then
Set DRange = ARange
Else
Set DRange = Union(DRange, ARange)
End If
End If
Next ARange
If Not DRange Is Nothing Then DRange.EntireRow.Delete
With ws.Rows(X & ":" & .Rows.Count).Delete
End With
End Sub
I put some code in from here How do I delete everything below row X in VBA/Excel?, but I am getting the
compile error Invalid or unqualified reference
The code worked before adding in this line
With ws.Rows(X & ":" & .Rows.Count).Delete
how would I go about deleting the rows behind the cleaned up data?
Option Explicit
Sub ConstructionTools()
'Dim ARange As Range
'Dim DRange As Range
Dim ws As Worksheet
'Dim wsB As Worksheet
'Dim filename As String
Set ws = Sheets("Data")
'Set wsB = Sheets("Macro")
'Set DRange = Nothing
Dim RowIndex as long
Dim Counter as long
With ws.Range("L1:L28000")
Dim RowsToDelete() as string
Redim rowstodelete(1 to .rows)
For rowindex = .rows to 1 step -1
Select case .cells(rowindex,1).value
Case "BUILDING CONSTRUCTION", "CONSTRUCTION SERVICES", "HEAVY & HIGHWAY" Or "HEAVY CIVIL - SPS"
Counter = counter + 1
Rowstodelete(counter) = .cells(rowindex,1).address
End select
Next rowindex
End with
If counter >0 then
Redim preserve RowsToDelete(1 to Counter)
With application
.screenupdating = false
.displayalerts = false
.calculation = xlcalculationmanual
Ws.range(strings.join(RowsToDelete,",")).entirerow.delete
.screenupdating = true
.displayalerts = true
.calculation = xlcalculationautomatic
End if
End sub
Untested and written on mobile, sorry for bad formatting. Code attempts to add the addresses of all rows which need to be deleted to an array, and then tries to delete all added rows in one go.
I want to remove all sheets in the current workbook exception the list in {A2,A3, ... } and the sheet with name Summary.
I wrote the following code
Dim MyCell As Range, MyRange As Range
Set MyRange = Sheets("Summary").Range("A2")
Set MyRange = Range(MyRange, MyRange.End(xlDown))
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set wbook = ActiveWorkbook
For Each xWs In wbook.Worksheets
For Each MyCell In MyRange
If xWs.Name <> MyCell.Value And xWs.Name <> "Summary" Then
xWs.Delete
End If
Next MyCell
Next
Application.DisplayAlerts = True
Application.ScreenUpdating = True
but I get an run time error which I do not know what it is.
Then, I tried to run line by line: in the first loop over "xWs.Name= Summary" there is no problem first for the second sheet I get an error at
If xWs.Name <> MyCell.Value And xWs.Name <> "Summary" Then
I know that this code is not efficient at all, because if a name matches it is still running till the end of set of names. However, I did not know how I can compare tow sets in VBA in a efficient way.
One can see in the the list of names in A-column.
You need to approach it a little different, you need to loop though the Range on every Sheet, once you have a match you need to raise a flag not to delete this Sheet.
Try the code below:
Sub DeleteSelectedSheets()
Dim MyCell As Range, MyRange As Range
Dim wbook As Workbook, xWs As Worksheet
Dim DeleteSheetFlag As Boolean
Set MyRange = Sheets("Summary").Range("A2")
Set MyRange = Range(MyRange, MyRange.End(xlDown))
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set wbook = ActiveWorkbook
For Each xWs In wbook.Worksheets
DeleteSheetFlag = True
For Each MyCell In MyRange
Select Case xWs.Name
Case MyCell.Value, "Summary"
DeleteSheetFlag = False
Exit For
End Select
Next MyCell
If DeleteSheetFlag Then
xWs.Delete
End If
Next xWs
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
So far, I have an excel file as such
http://i.stack.imgur.com/zX3xC.png
My problem is that I want to be able to input a number after having the search button pressed and an Input box appears, With the number in the search bar for all numbers that match in the spreadsheet to be selected.
Also as as addition to be able to put in a few numbers (40, 21, 33 separated by commas)
My current code is:
Sub SEARCH_Click()
Dim sh1 As Sheet1
Dim rng As Range
Dim uname As String
Set sh1 = Sheet1: uname = InputBox("Input")
With Application
.ScreenUpdating = False
.DisplayAlerts = False
End With
With sh1
.AutoFilterMode = False
Set rng = .Range("A4", .Range("A" & .Rows.Count).End(xlUp))
On Error Resume Next
rng.SpecialCells(xlCellTypeVisible).Select
If Err.number <> 0 Then MsgBox "Data not found" _
Else MsgBox "All matching data has been selected"
.AutoFilterMode = False
On Error GoTo 0
End With
With Application
.ScreenUpdating = True
.DisplayAlerts = True
End With
End Sub
I am fairly new to coding so a lot of this has come from internet research etc.
Abandon your AutoFilter method in favor of a Range.Find method. While ultimately possible with a series of .AutoFilters applied to each column, simply collecting the results from a .Find operation with the Union method makes more sense.
Private Sub CommandButton1_Click()
Dim uname As String, sh1 As Worksheet '<~~ there is no var type called Sheet1
Dim v As Long, fnd As Range, rng As Range, addr As String, vals As Variant
Set sh1 = Sheet4
uname = InputBox("Search for...")
vals = Split(Replace(uname, Chr(32), vbNullString) & Chr(44), Chr(44))
ReDim Preserve vals(UBound(vals) - 1)
With sh1
For v = LBound(vals) To UBound(vals)
If IsNumeric(vals(v)) Then vals(v) = Val(vals(v))
Set fnd = .Cells.Find(What:=vals(v), LookIn:=xlValues, LookAt:=xlWhole, _
SearchOrder:=xlByRows, SearchFormat:=False)
If Not fnd Is Nothing Then
addr = fnd.Address
Do
If rng Is Nothing Then
Set rng = fnd
Else
Set rng = Union(rng, fnd)
End If
Set fnd = .Cells.FindNext(after:=fnd)
Loop Until addr = fnd.Address
End If
addr = vbNullString
Set fnd = Nothing
Next v
If Not rng Is Nothing Then rng.Select
End With
End Sub
It is not clear what actions you want to perform after the Range .Select¹ method has been applied. I would suggest that a simple With ... End With statement woudl allow you to continue working on the rng discontiguous Range object without actually selecting it at all.
¹ See How to avoid using Select in Excel VBA macros for more methods on getting away from relying on select and activate to accomplish your goals.
I have two ranges A2:E2 and B1:B5. Now if I perform intersect operation it will return me B2. I want some way through which I can get my output as B2 to be consider in any one range either A2:E2 and B1:B5. i.e if there is a repeated cell then it should be avoided.
Expected output :
A2,C2:E2,B1:B5
OR
A2:E2,B1,B3:B5
Can anyone help me.
Like this?
Sub Sample()
Dim Rng1 As Range, Rng2 As Range
Dim aCell As Range, FinalRange As Range
Set Rng1 = Range("A2:E2")
Set Rng2 = Range("B1:B5")
Set FinalRange = Rng1
For Each aCell In Rng2
If Intersect(aCell, Rng1) Is Nothing Then
Set FinalRange = Union(FinalRange, aCell)
End If
Next
If Not FinalRange Is Nothing Then Debug.Print FinalRange.Address
End Sub
OUTPUT:
$A$2:$E$2,$B$1,$B$3:$B$5
EXPLANATION: What I am doing here is declaring a temp range as FinalRange and setting it to Range 1. After that I am checking for each cell in Range 2 if it is present in Range 1. If it is then I am ignoring it else adding it using Union to the Range 1
EDIT Question was also cross posted here
From my article Adding a "Subtract Range" method alongside Union & Intersect
This code can be used to
Subtract the intersect of one range from a second range
Return the anti-union of two separate ranges (ie exclude only cells that intersetc)
I use this code in Mappit! to indentify hidden cells (ie Hidden Cells = UsedRange - SpecialCells(xlVisible)).
While this code is relatively lengthy it was written to be very quick on larger ranges, avoiding cell loops
Sub TestMe()
Dim rng1 As Range
Dim rng2 As Range
Set rng1 = [a2:e2]
Set rng2 = [b1:b5]
MsgBox RemoveIntersect(rng1, rng2) & " " & rng2.Address(0, 0)
End Sub
Function RemoveIntersect(ByRef rng1 As Range, ByRef rng2 As Range, Optional bBothRanges As Boolean) As String
Dim wb As Workbook
Dim ws1 As Worksheet
Dim rng3 As Range
Dim lCalc As Long
'disable screenupdating, event code and warning messages.
'set calculation to Manual
With Application
.ScreenUpdating = False
.EnableEvents = False
.DisplayAlerts = False
lCalc = .Calculation
.Calculation = xlCalculationManual
End With
'add a working WorkBook
Set wb = Workbooks.Add(1)
Set ws1 = wb.Sheets(1)
On Error Resume Next
ws1.Range(rng1.Address).Formula = "=NA()"
ws1.Range(rng2.Address).Formula = vbNullString
Set rng3 = ws1.Cells.SpecialCells(xlCellTypeFormulas, 16)
If bBothRanges Then
ws1.UsedRange.Cells.ClearContents
ws1.Range(rng2.Address).Formula = "=NA()"
ws1.Range(rng1.Address).Formula = vbNullString
Set rng3 = Union(rng3, ws1.Cells.SpecialCells(xlCellTypeFormulas, 16))
End If
On Error GoTo 0
If Not rng3 Is Nothing Then RemoveIntersect = rng3.Address(0, 0)
'Close the working file
wb.Close False
'cleanup user interface and settings
'reset calculation
With Application
.ScreenUpdating = True
.EnableEvents = True
.DisplayAlerts = True
lCalc = .Calculation
End With
End Function