I have a file called "gar_nv", "nbrLines" is the number of lines ,defined in my code. I have given names to my columns. "listCol" is a function returning a list of these names.
I would like to set all empty cells to zero except the cells of the following columns: "GCFRRE", "GCDEP1", "GCDEP2", "GCDEP3", "GCTYC0", "GCTYC1", "GCTYC2", "GCTYC3","GCBAC0", "GCBAC1", "GCBAC2", "GCBAC3". Knowing I have thousands of rows, this code takes a long time to run. Is there a way to make it faster ?
Dim rng As Variant, i As Long
With gar_nv
For i = 1 To nbrLines - 1
For Each rng In ListCol
Select Case rng
Case "GCFRRE", "GCDEP1", "GCDEP2", "GCDEP3", _
"GCTYC0", "GCTYC1", "GCTYC2", "GCTYC3", _
"GCBAC0", "GCBAC1", "GCBAC2", "GCBAC3"
Case Else
If IsEmpty(.range(rng).Rows(i)) = True Then
.range(rng).Rows(i).Value = "0"
End If
End Select
Next rng
Next i
End With
Let's say your columns are named ranges like headers in the image:
You can do:
Sub test()
Application.ScreenUpdating = False
Dim rng As Range
Dim Listcol As Variant
Dim i As Long
Listcol = Array("A", "B", "C_", "D") 'list of all named ranges
For i = 0 To UBound(Listcol)
Select Case Listcol(i)
Case "B"
'we do nothing
Case Else
'we replace blanks with 0
Set rng = Range(Listcol(i)).SpecialCells(xlCellTypeBlanks)
rng.FormulaR1C1 = "=0" ' set them to 0
rng.Value = rng.Value 'replace formula with value
Set rng = Nothing
End Select
Next i
Erase Listcol
Application.ScreenUpdating = True
End Sub
Notice named range B has been excluded:
Related
I have been working on automating different parts of the process of formatting a very large data set. I am stuck on trying to automate the "remove duplicates" command across all blocks of my data:
I have blocks of data (9 columns wide, x rows long) as on the image attached. In the column called "#Point ID" are values 0-n. Some values appear once, some values appear more than once. Different blocks have different "#Point ID" columns
I would like to delete all rows in the block where the value in the "#Point ID" column has already occurred (starting from the top, moving down the rows). I would like the deleted rows removed from the blocks, so only the rows (which are blue on the image) with unique values in "#Point ID" column (green on the image) remain.
I have found VBA modules that work on a single block, but I don't know how to make it function across all my blocks. Delete rows in Excel based on duplicates in Column
I have also tried combinations of functions (inc. UNIQUE and SORTBY) without any success.
What's a function or a VBA module that works?
Use this
Public Sub cleanBlock(rng As Range)
Dim vals As Object
Set vals = CreateObject("Scripting.Dictionary")
Dim R As Range
Dim adds As Range
For Each R In rng.Rows
If (vals.exists(R.Cells(1, 2).Value)) Then
If adds Is Nothing Then
Set adds = R
Else
Set adds = Union(adds, R)
End If
Else
vals(R.Cells(1, 2).Value) = True
End If
Next R
Debug.Print (adds.Address)
If Not adds Is Nothing Then adds.Delete shift:=xlUp
Set vals = Nothing
End Sub
Public Sub test()
cleanBlock Range("b3:j20")
cleanBlock Range("l3:t20")
cleanBlock Range("y3:ad20")
End Sub
Remove Duplicates in Areas of a Range
Sub RemoveDupesByAreas()
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
Dim ws As Worksheet: Set ws = wb.Sheets("Sheet1") ' adjust!
Dim rg As Range: Set rg = ws.UsedRange.SpecialCells(xlCellTypeConstants)
Dim aCount As Long: aCount = rg.Areas.Count
Dim arg As Range, a As Long
For a = aCount To 1 Step -1
Set arg = rg.Areas(a)
Debug.Print a, arg.Address(0, 0)
' Before running the code with the next line, in the Immediate
' window ('Ctrl+G'), carefully check if the range addresses
' match the areas of your data. If they match, uncomment
' the following line to apply remove duplicates.
'arg.RemoveDuplicates 2, xlYes
Next a
MsgBox "Duplicates removed.", vbInformation
End Sub
Find and FindNext feat. CurrentRegion
Sub RemoveDupesByFind()
Const SEARCH_STRING As String = "Source.Name"
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
Dim ws As Worksheet: Set ws = wb.Sheets("Sheet1") ' adjust!
Dim rg As Range: Set rg = ws.UsedRange
Dim fCell As Range: Set fCell = rg.Find( _
SEARCH_STRING, , xlFormulas, xlWhole, xlByRows, xlPrevious)
If fCell Is Nothing Then
MsgBox """" & SEARCH_STRING & """ not found.", vbCritical
Exit Sub
End If
Dim FirstAddress As String: FirstAddress = fCell.Address
Do
fCell.CurrentRegion.RemoveDuplicates 2, xlYes
Set fCell = rg.FindNext(fCell)
Loop Until fCell.Address = FirstAddress
MsgBox "Duplicates removed.", vbInformation
End Sub
Another way, maybe something like this :
Sub test()
Dim rgData As Range
Dim rg As Range: Dim cell As Range
Dim rgR As Range: Dim rgDel As Range
Set rgData = Sheets("Sheet1").UsedRange 'change as needed
Set rgData = rgData.Resize(rgData.Rows.Count - 1, rgData.Columns.Count).Offset(1, 0)
For Each rg In rgData.SpecialCells(xlConstants).Areas
For Each cell In rg.Columns(2).Cells
Set rgR = cell.Offset(0, -1).Resize(1, rg.Columns.Count)
If cell.Value = 0 And cell.Offset(1, 0).Value <> 0 And cell.Offset(0, 1).Value = 0 And cell.Address = rg.Columns(2).Cells(1, 1).Address Then
Else
If Application.CountIf(rg.Columns(2), cell.Value) > 1 And cell.Offset(0, 1).Value = 0 Then
If rgDel Is Nothing Then Set rgDel = rgR Else Set rgDel = Union(rgDel, rgR)
End If
End If
Next cell
Next rg
rgDel.Delete Shift:=xlUp
End Sub
The code assumed that there'll be no blank cell within each block and there will be full blank column (no value at all) between each block. So it sets the usedrange as rgData variable, and loop to each area/block in rgData as rg variable.
Within rg, it loop to each cell in rg column 2, and check if the count of the looped cell value is > 1 and the value of the looped cell.offset(0,1) is zero, then it collect the range as rgDel variable.
Then finally it delete the rgDel.
If you want to step run the code, try to add something like this rg.select ... rgR.select .... after the variable is set. For example, add rgDel.select right before next area, so you can see what's going on.
The code assume that :
the first value right under "#Point" in each block will be always zero. It will
never happen that the value is other than zero.
the next value (after that zero value) is maybe zero again or maybe one.
if there are duplicates (two same value) in column #Point then in column X, it's not fix that the first one will always have value and the second one will always zero value.
If the data is always fix that the first one will always have value and the second one will always zero value (if there are duplicate), I suggest you to use Mr. VBasic2008 or Mr. wrbp answer. Thank you.
I've made a For Each loop that'll keep data depending upon some criteria's, but I do not know how to format it so if a cell in column A contain exactly 8 numeric digits, then it'll keep the row.
Example:
Cell A289 Contains: 04245468 ← Keep this row
Cell A978 Contains: 04513 ← Delete this row
So far I have the following by using the left function within my code:
Sub CleanUpSheet1()
Dim RowA As Range
'hides any popups
Application.DisplayAlerts = False
'Deletes all blanks up to row 15,0000
Range("a2:A15000").Select
Selection.SpecialCells(xlCellTypeBlanks).EntireRow.Delete
For Each RowA In Range("A2:A" & ActiveSheet.UsedRange.Rows.Count)
If Left(RowA.Value, 5) <> "issue" And Right(RowA.Value, 4) <> "-000" And RowA.Value <> 0 Then
RowA.EntireRow.Delete
End If
Next
're-enables popups
Application.DisplayAlerts = True
End Sub
If it's just a matter of numbers you can transform the cell value into a string (RowA.Text or maybe Cstr(RowA.Value) and then test on the lenght :
if len(cstr(RowA.Value)) = 8 ???
(or len(RowA.Text))
Tell me if I havn't understood your question.
Had to reformat this a lot.
Sub CleanUpSelect1()
Dim RowA As Range
Dim cRng As Range
Dim iCounter As Long
Set RowA = Sheet1.Range("A2:A" & Sheets("Sheet1").UsedRange.Rows.Count)
iCounter = 1
Do
Set cRng = RowA(iCounter, 1) 'Loop rows
If CStr(cRng.Value2) = vbNullString Then
cRng.EntireRow.Delete
Else
If Not KeepRow(cRng.Value2) Then
cRng.EntireRow.Delete 'Delete row
Else
iCounter = iCounter + 1 'Advance
End If
End If
Loop While iCounter <= RowA.Rows.Count 'Stop after loop all rows
End Sub
Private Function KeepRow(RowValue As String) As Boolean
KeepRow = (RowValue Like "########" Or RowValue Like "issue#" Or RowValue Like "######-###")
End Function
But it works.
I am completely new to visual basic. I have a few spreadsheets containing numbers. I want to delete any rows containing numbers outside of specific ranges. Is there a straightforward way of doing this in visual basic?
For example, in this first spreadsheet (image linked) I want to delete rows that contain cells with numbers outside of these two ranges: 60101-60501 and 74132-74532.
Can anyone give me some pointers? Thanks!
Code
You need to call it for your own needs as shown on the routine "Exec_DeleteRows". I assumed that you needed if it is equals or less to the one that you state on your routine. In this example, I will delete the rows where values are between 501-570 and then the ones between 100-200
Sub Exec_DeleteRows()
Call Exec_DeleteRowsInRangeBasedOnNumberValue(Range("C8:H11"), 501, 570)
Call Exec_DeleteRowsInRangeBasedOnNumberValue(Range("C8:H11"), 100, 200)
End Sub
Sub Exec_DeleteRowsInRangeBasedOnNumberValue(RangeToWorkIn As Range, NumPivotToDeleteRowBottom As Double, NumPivotToDeleteRowTop As Double)
Dim RangeRowsToDelete As Range
Dim ItemRange As Range
For Each ItemRange In RangeToWorkIn
If IsNumeric(ItemRange.Value) = False Then GoTo SkipStep1
If ItemRange.Value >= NumPivotToDeleteRowBottom And ItemRange.Value <= NumPivotToDeleteRowTop Then ' 1. If ItemRange.Value >= NumPivotToDeleteRowBottom And ItemRange.Value <= NumPivotToDeleteRowTop
If RangeRowsToDelete Is Nothing Then ' 2. If RangeRowsToDelete Is Nothing
Set RangeRowsToDelete = RangeToWorkIn.Parent.Rows(ItemRange.Row)
Else ' 2. If RangeRowsToDelete Is Nothing
Set RangeRowsToDelete = Union(RangeToWorkIn.Parent.Rows(ItemRange.Row), RangeRowsToDelete)
End If ' 2. If RangeRowsToDelete Is Nothing
End If ' 1. If ItemRange.Value >= NumPivotToDeleteRowBottom And ItemRange.Value <= NumPivotToDeleteRowTop
SkipStep1:
Next ItemRange
If Not (RangeRowsToDelete Is Nothing) Then RangeRowsToDelete.EntireRow.Delete
End Sub
Demo
Delete Rows Containing Wrong Numbers
It is assumed that the data starts in A1 of worksheet Sheet1 in the workbook containing this code (ThisWorkbook) and has a row of headers (2).
This is just a basic example to get familiar with variables, data types, objects, loops, and If statements. It can be improved on multiple accounts.
Option Explicit
Sub DeleteWrongRows()
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
Dim ws As Worksheet: Set ws = wb.Worksheets("Sheet1") ' worksheet
Dim rg As Range: Set rg = ws.Range("A1").CurrentRegion ' range
Application.ScreenUpdating = False
Dim rrg As Range ' Row Range
Dim rCell As Range ' Cell in Row Range
Dim rValue As Variant ' Value in Cell
Dim r As Long ' Row
Dim DoDelete As Boolean
' Loop backwards through the rows of the range.
For r = rg.Rows.Count To 2 Step -1
Set rrg = rg.Rows(r)
' Loop through cells in row.
For Each rCell In rrg.Cells
rValue = rCell.Value
If IsNumeric(rValue) Then ' is a number
If rValue >= 60101 And rValue <= 60501 Then ' keep
ElseIf rValue >= 74132 And rValue <= 74532 Then ' keep
Else ' delete (outside the number ranges)
DoDelete = True
End If
Else ' is not a number
DoDelete = True
End If
If DoDelete Then ' found a cell containing a wrong value
rCell.EntireRow.Delete
DoDelete = False
Exit For ' no need to check any more cells
'Else ' found no cell containing a wrong value (do nothing)
End If
Next rCell
Next r
Application.ScreenUpdating = True
MsgBox "Rows with wrong numbers deleted.", vbInformation
End Sub
Using Range.Delete is the built-in way of completely erasing a row in Excel VBA. To check an entire row for numbers meeting a certain criteria, you would need a Loop and an If Statement.
To evaluate a lot of values at a faster pace, it is smart to first grab the relevant data off the Excel sheet into an Array. Once in the array, it is easy to set up the loop to run from the first element (LBound) to the final element (UBound) for each row and column of the array.
Also, when deleting a lot of Ranges from a worksheet, it is faster and less messy to first collect (Union) the ranges while you're still looping, and then do the delete as a single step at the end. This way the Range addresses aren't changing during the loop and you don't need to re-adjust in order to track their new locations. That and we can save a lot of time since the application wants to pause and recalculate the sheet after every Deletion.
All of those ideas put together:
Sub Example()
DeleteRowsOutside ThisWorkbook.Worksheets("Sheet1"), Array(60101, 60501), Array(74132, 74532)
End Sub
Sub DeleteRowsOutside(OnSheet As Worksheet, ParamArray Min_and_Max() As Variant)
If OnSheet Is Nothing Then Set OnSheet = ActiveSheet
'Find the Bottom Corner of the sheet
Dim BottomCorner As Range
Set BottomCorner = OnSheet.Cells.Find("*", After:=OnSheet.Range("A1"), SearchDirection:=xlPrevious)
If BottomCorner Is Nothing Then Exit Sub
'Grab all values into an array
Dim ValArr() As Variant
ValArr = OnSheet.Range(OnSheet.Cells(1, 1), BottomCorner).Value
'Check each row value against min & max
Dim i As Long, j As Long, DeleteRows As Range
For i = LBound(ValArr, 1) To UBound(ValArr, 1) 'For each Row
For j = LBound(ValArr, 2) To UBound(ValArr, 2) 'For each column
Dim v As Variant: v = ValArr(i, j)
If IsNumeric(v) Then
Dim BoundaryPair As Variant, Is_Within_A_Boundary As Boolean
Is_Within_A_Boundary = False 'default value
For Each BoundaryPair In Min_and_Max
If v >= BoundaryPair(0) And v <= BoundaryPair(1) Then
Is_Within_A_Boundary = True
Exit For
End If
Next BoundaryPair
If Not Is_Within_A_Boundary Then
'v is not within any acceptable ranges! Mark row for deletion
If DeleteRows Is Nothing Then
Set DeleteRows = OnSheet.Rows(i)
Else
Set DeleteRows = Union(DeleteRows, OnSheet.Rows(i))
End If
GoTo NextRow 'skip to next row
End If
End If
Next j
NextRow:
Next i
If Not DeleteRows Is Nothing Then DeleteRows.EntireRow.Delete
End Sub Exit For 'skip to next row
End If
End If
Next j
Next i
If Not DeleteRows Is Nothing Then DeleteRows.EntireRow.Delete
End Sub
I use a ParamArray to accept a variable number of Min and Max ranges. To keep things tidy, the Min and Max pairs are each in an array of their own. As long as all the numbers in the row are within any of the provided ranges, the row will not be deleted.
Here's some code with Regex and with scripting dictionary that I've been working on. I made this for my purposes, but it may be useful here and to others.
I found a way for selecting noncontinguous cells based on an array and then deleting those cells.
In this case, I selected by row number because VBA prevented deletion of rows due to overlapping ranges.
Sub findvalues()
Dim Reg_Exp, regexMatches, dict As Object
Dim anArr As Variant
Dim r As Range, rC As Range
Set r = Sheets(3).UsedRange
Set r = r.Offset(1).Resize(r.Rows.Count - 1, r.Columns.Count)
Set Reg_Exp = CreateObject("vbscript.regexp")
With Reg_Exp
.Pattern = "^[6-6]?[0-0]?[1-5]?[0-0]?[1-1]?$|^60501$" 'This pattern is for the 60101 to 60501 range.
End With
Set dict = CreateObject("Scripting.Dictionary")
For Each rC In r
If rC.Value = "" Then GoTo NextRC ''skip blanks
Set regexMatches = Reg_Exp.Execute(rC.Value)
If regexMatches.Count = 0 Then
On Error Resume Next
dict.Add rC.Row & ":" & rC.Row, 1
End If
NextRC:
Next rC
On Error GoTo 0
anArr = Join(dict.Keys, ", ")
Sheets(3).Range(anArr).Delete Shift:=xlShiftUp
End Sub
I am not too experienced in VBA but found a code online that creates combinations in an excel sheet. This is great except, I need a rule in there that it should skip cells in the combination generator when empty. I tried a couple setups but it kept giving me the same result over and over.
So if i have the following table:
Table 1
Table 2
1
a
b
3
c
The outcome should result in:
1-a
1-b
1-c
3-a
3-b
3-c
However, it leads to:
1-a
1-b
1-c
-a
-b
-c
3-a
3-b
3-c
Anyone can give me a tip or idea to see if this can be solved? Would love to know what is possible before investing too much time in it. Find the VBA below. Thanks in advance!
Sub CombinationGenerator()
Dim xDRg1, xDRg2, xDRg3 As Range
Dim xRg As Range
Dim xStr As String
Dim xFN1, xFN2, xFN3 As Integer
Dim xSV1, xSV2, xSV3 As String
Set xDRg1 = Range("A2:A6") 'First column data
Set xDRg2 = Range("B2:B2") 'Second column data
Set xDRg3 = Range("C2:C2") 'Third column data
xStr = "-" 'Separator
Set xRg = Range("E2") 'Output cell
'Creating combinations
For xFN1 = 1 To xDRg1.Count
If Cells(xFN1, "A") <> "" Then 'Ignore empty cells
xSV1 = xDRg1.Item(xFN1).Text
For xFN2 = 1 To xDRg2.Count
xSV2 = xDRg2.Item(xFN2).Text
For xFN3 = 1 To xDRg3.Count
xSV3 = xDRg3.Item(xFN3).Text
xRg.Value = xSV1 & xStr & xSV2 & xStr & xSV3
Set xRg = xRg.Offset(1, 0)
Next
Next
End If
Next
End Sub
xFN1 iterates from 1 to xDRg1.Cells.Count but the first row of xDRg1 is 2. So when you rebuild the range during the line Cells(xFN1, "A") you're putting 1, 2, 3 instead of 2, 3, 4 for the row numbers.
To avoid confusing code like this, I would suggest switching the For loop to a For Each loop using the Range.Cells collection, meaning the loop element would be a Cell (Range Object) instead of a Row number.
Sub CombinationGenerator()
Dim xDRg1 As Range, xDRg2 As Range, xDRg3 As Range
Dim xRg As Range
Dim xStr As String
Dim xFN1 As Range, xFN2 As Range, xFN3 As Range
Dim xSV1 As String, xSV2 As String, xSV3 As String
Set xDRg1 = Range("A2:A6") 'First column data
Set xDRg2 = Range("B2:B2") 'Second column data
Set xDRg3 = Range("C2:C2") 'Third column data
xStr = "-" 'Separator
Set xRg = Range("E2") 'Output cell
'Creating combinations
For Each xFN1 In xDRg1.Cells
If xFN1 <> "" Then 'Ignore empty cells
xSV1 = xFN1.Text
For Each xFN2 In xDRg2.Cells
xSV2 = xFN2.Text
For Each xFN3 In xDRg3.Cells
xSV3 = xFN3.Text
xRg.Value = xSV1 & xStr & xSV2 & xStr & xSV3
Set xRg = xRg.Offset(1, 0)
Next
Next
End If
Next
End Sub
I need to select an entire row based on criteria value="REZ" in column "C".
Dim c As Range
Dim rngG As Range
For Each c In Intersect(ActiveSheet.UsedRange, Columns("C"))
If c = "REZ" Then
If rngG Is Nothing Then Set rngG = c.EntireRow
Set rngG = Union(rngG, c.EntireRow)
End If
Next c
rngG.Select
Each selected row has some value in column "J".
I now need to additionally select all entire rows that contains those values gotten from first step.
Images to better explain:
First get rows with "REZ" in column "C"
Now we know that rows value in column "J" which in this case is "27.2.12".
So now in addition to what we have selected we need to select all the rows that contain "27.2.12" which is ALWAYS some number of rows directly after the row found and selected in step 1 and never match exactly as each value in column "J" is unique.
In this case it would be:
I imagine two IF functions where the second one takes the info from the result of the first.
Workbook example: https://easyupload.io/yewg9o
I highlighted "REZ" rows with yellow that are selected in step 1 and cells that I expect to be selected based on step 1 are highlighted with green.
Try this out:
Sub Tester()
Dim c As Range, ws As Worksheet
Dim rngG As Range, lastJ, rngJ As Range
Set ws = ActiveSheet
For Each c In Intersect(ws.UsedRange, ws.Columns("C"))
Set rngJ = c.EntireRow.Columns("J")
If c = "REZ" Then
AddRange rngG, c.EntireRow
lastJ = rngJ.Value 'remember the J value
Else
'not REZ, but see if we're to check for matching J values
If Len(lastJ) > 0 Then
If rngJ.Value Like lastJ & "*" Then
AddRange rngG, c.EntireRow
Else
lastJ = "" 'stop checking on first non-match
End If
End If
End If
Next c
rngG.Select
End Sub
'Utility sub for building up a range
Sub AddRange(rngTot As Range, rngAdd As Range)
If rngTot Is Nothing Then
Set rngTot = rngAdd
Else
Set rngTot = Application.Union(rngTot, rngAdd)
End If
End Sub