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
Related
Given that I am told we should be using Centered Across Selection instead of Merged Cells, I need to get the underlying value that is displayed across the cells when formatted as Centered Across Selection.
When using Merged Cells, it was easy:
CellValue = rng.MergeArea.Cells(1, 1).Value
Is there an easy way to get the same for Centered Across Selection, other than searching backwards while HorizontalAlignment = xlHAlignCenterAcrossSelection until the Cell Value <> "". My code to do this would be:
Function GetCenteredAcrossSelectionCellValue(rng As Range) As Variant
Dim i As Long
Dim l As Long
Dim ws As Worksheet
Set ws = rng.Worksheet
i = rng.Column
r = rng.Row
If rng.HorizontalAlignment = xlHAlignCenterAcrossSelection Then
Do Until (ws.Cells(r, i).Value <> "" And rng.HorizontalAlignment = xlHAlignCenterAcrossSelection)
i = i - 1
Loop
End If
GetCenteredAcrossSelectionCellValue = ws.Cells(r, i).Value
End Function
However, I don't this this is foolproof, because it could be possible that someone applied Center Across Selection to a single cell (say A1 for example) with a value, and then applied Center Across Selection to 3 empty cells (B1:D1). When asked for the "value" for D1, the above code would return the value in A1.
Excel must know because it formats correctly, so is there an easy way to tell in VBA, similar to the way we can tell for Merged Cells?
Following on from the comment above...
Apply "center across selection" to A1:J1 then run tester with values in different cells in that range and compare the outputs.
Sub tester()
Dim c As Range, rng As Range
For Each c In Range("A1:J1")
Set rng = CenteredRange(c)
If Not rng Is Nothing Then
Debug.Print c.Address, rng.Address
Else
Debug.Print c.Address, "not centered"
End If
Next c
End Sub
'return the current "center across" range given a starting point
Function CenteredRange(c As Range) As Range
Dim cStart As Range, cEnd As Range, cNext As Range
Set c = c.Cells(1) 'make sure we're dealing with a single cell
If Not c.HorizontalAlignment = xlCenterAcrossSelection Then Exit Function
Set cStart = c.Parent.Range(c.Address)
Set cEnd = c.Parent.Range(c.Address)
'look for the beginning
Do While cStart.Column > 1 And cStart.HorizontalAlignment = xlCenterAcrossSelection
If Len(cStart.Value) > 0 Then Exit Do 'stop if find a value
Set cStart = cStart.Offset(0, -1)
Loop
'look for the end
Do While cEnd.Column < Columns.Count - 1 And cEnd.HorizontalAlignment = xlCenterAcrossSelection
Set cNext = cEnd.Offset(0, 1) 'checking the next cell...
If Len(cNext.Value) > 0 Or cNext.HorizontalAlignment <> xlCenterAcrossSelection Then Exit Do
Set cEnd = cEnd.Offset(0, 1)
Loop
Set CenteredRange = c.Parent.Range(cStart, cEnd)
End Function
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:
I am trying to find all values greater than 6 in the Rep column, delete the entire row, and insert a blank row.
I tried For Each Next loop, With and Do While. The dataset has over 5000 rows so I chose the column as range but it won't go to the next or the app crashes.
I searched the internet but there are few useful sources for what I'm trying to do. The code I have is a mash of approaches.
Public Sub DRS_FindAll_Delete()
Dim c As Range
Dim firstAddress As String
Dim WorkRng As Range
Set WorkRng = Application.Selection
Set WorkRng = Application.InputBox("Range (Column)", xTitleID, WorkRng.Address, Type:=8)
Dim x As Integer
x = xlValues > 6
For Each c In WorkRng
Set c = Cells.Find(x, LookIn:=xlValues)
If Not c Is Nothing Then
firstAddress = c.Address
Do
x.EntireRow.Delete
Set c = Cells.FindNext(c)
Loop While Not c Is Nothing
End If
Next
MsgBox ("All done!")
Clear Entire Rows
A Few Issues
If you cancel the input box, an error will occur.
What does the line x = xlValues > 6 do? If we know that xlValues = -4163 then x will be equal to a False converted to an integer i.e. x = 0. To conclude, your procedure will clear all (entire) rows whose cells in the selected column are equal to 0, if you replace x.EntireRow.Delete with c.EntireRow.Clear.
Once a cell (c) has been found and cleared, firstAddress = c.Address becomes redundant. You're not using it anyway.
A Different Approach
Whatever is selected via the input box, only the first cell is considered. It will assume that the column of the first cell contains one row of headers (row 1) and will use the cells up to the last non-empty cell. By using AutoFilter, it will filter all values greater than 6 and finally, clear the entire rows of the filtered cells.
Option Explicit
Sub DRS_FindAll_Clear()
Const Criteria As String = ">6"
Const aibPrompt As String = "Select a cell in the desired column"
Const aibTitle As String = "DRS_FindAll_Clear"
Dim aibDefault As String
If TypeOf Selection Is Range Then
aibDefault = Selection.Address
End If
Dim WorkRng As Range
On Error Resume Next
Set WorkRng = Application.InputBox( _
aibPrompt, aibTitle, aibDefault, , , , , 8)
On Error GoTo 0
If WorkRng Is Nothing Then Exit Sub
Application.ScreenUpdating = False
Dim ws As Worksheet: Set ws = WorkRng.Worksheet
If ws.FilterMode Then ws.ShowAllData
Dim strg As Range ' Table Range (has headers)
With ws.Columns(WorkRng.Column)
Dim lCell As Range: Set lCell = .Find("*", , xlFormulas, , , xlPrevious)
If lCell Is Nothing Then Exit Sub ' no data in column
Set strg = .Cells(1).Resize(lCell.Row)
End With
Dim sdrg As Range ' Data Range (no headers)
Set sdrg = strg.Resize(strg.Rows.Count - 1).Offset(1)
strg.AutoFilter 1, Criteria
Dim svdrg As Range ' Data Visible Range (no headers)
On Error Resume Next
Set svdrg = sdrg.SpecialCells(xlCellTypeVisible)
On Error GoTo 0
ws.AutoFilterMode = False
If svdrg Is Nothing Then Exit Sub
svdrg.EntireRow.Clear
Application.ScreenUpdating = True
MsgBox "All done!"
End Sub
This is the second time today this issue has come up in a SO question.
For each c in Workrng
is incorrect when you are deleting items from a collection (and yes workrng is a collection).
When you delete items from a collection in a loop you must not change the part of the collection that still has to be iterated over.
Lets say you have rows 1 to 10 and you have reached row 3 which you now delete.
When you do this, there will only be 9 rows. However, the control variable for the for each doesn't know you have deleted a row so its still counting to 10, even worse its going to skip a row, because what was row 4 is, after your deletion, now row 3. So when the control variable looks for row 4 it will actually be getting what was row 5, so the old row 4( which is now row 3) doesn't get processed at all.
Thus for collections you can only safely delete the last item in the collection. Consequently you can't use 'for each' you must use 'for i = count to 1 step -1'
I'm trying to loop trough each row in the range J16:P19, and with every iteration, it must be checked if the value in the cell = 3, and if the text in the corresponding coloumn (range J15:J19) is present in the range ( W1:W7).
eg. If the cell (K17) in the row (J17:P17) = 3 & the corresponding coloumn name (K15) of that cell is present in the range ( W1:W7); the value of in Q17 must be substracked by 1.
This should be done for every row in the range. My code looks like this:
private Sub CommandButton2_Click()
dim rng As Range
dim i As Range
dim row As Range
Set rng = Range("j16:p19")
For Each row In rng.Rows
For Each i In row.Cells
If i.Value = 3 & Cells(i,15) %in% Range("w1:w7") Then
Cells(row,22).Value = Cells(row,17).Value -1
Else
Cells(row,22).Value = Cells(row,17).Value
End if
Next i
Next row
End sub
It works when I select the range to be one column only, and without the second part of the if statement. Do you have any suggestions on have to solve my problem? thank you in advance
Try this.
Not sure why you were referring to column 22? Also "%in%" is not valid VBA syntax. I've used Match instead (which avoids the outer loop), but you could use Find or Countif.
Private Sub CommandButton2_Click()
Dim rng As Range
Dim i As Range
Dim row1 As Range, v As Variant 'better in my view not to call a variable "row"
Set rng = Range("j16:p19")
For Each row1 In rng.Rows
v = Application.Match(3, row1, 0)
If IsNumeric(v) Then 'row contains a 3
If IsNumeric(Application.Match(Cells(row1.row,"J"), Range("W1:W7"), 0)) Then 'corresponding J column value in W1:W7
Cells(row1.row, "Q").Value = Cells(row1.row, "Q").Value - 1 'deduct 1 from Q
End If
End If
Next row1
End Sub
I am comparing two excelsheets in the same workbook.
I want to check whether the records from sheet1 are exactly same as records in sheet2 based on common Question_id(Column A of both worksheets)
This question_id(column A) has values such as
1
1a
1a.1
1a.1a
1a.1b
1a.1c
2
2a
2a.1
2a.1a
2a.1b
2a.1c etc....
I want to compare the records based on this Question_id(Column A Value).
If Question_id is same and records(the remaining row) are not same then am coloring those records in red background(only specific cells and not the whole row)
For the same, I have following code.
Sub RunCompare()
Call compareSheets("Sheet1", "Sheet2")
End Sub
Sub compareSheets(shtSheet1 As String, shtSheet2 As String)
Dim mycell As Range
Dim mydiffs As Integer
Application.ScreenUpdating = false
'Color Uncommon records in Red Background
For Each mycell In ActiveWorkbook.Worksheets(shtSheet2).UsedRange
If Not mycell.Value = ActiveWorkbook.Worksheets(shtSheet1).Cells(mycell.Row, mycell.Column).Value Then
mycell.Interior.Color = vbRed
mydiffs = mydiffs + 1
End If
Next
'Display no. of differences
MsgBox mydiffs & " differences found", vbInformation
ActiveWorkbook.Sheets(shtSheet2).Select
MsgBox "Data Scrubbed Successfully..."
Application.ScreenUpdating = True
End Sub
The above code runs fine when I have same sequence of Question_id (and therefore of records) in both the excelsheets.
Assume I have different sequence of Question_id (and therefore of records) in both the sheets.
Then how I can achieve this...?
Something Like using where clause in my code Where Sheet1.Question_id = Sheet2.Question_id
i.e. I'll pick up question_id and the full row from sheet1 and I will compare it against records in sheet2 based on matching Question_id(value of Column A) only.
Can someone tell where I can put the condition and what type of condition so that, even if both the excelsheets have random sequences of Question_id; I will be able to compare the records from sheet1 and sheet2.
EDIT: on 23rd March 2015
I have changed the code using find() method instead of loops as below:
Still I havn't arrived at my solution.
Here am trying to list Question_Ids of all non-matching rows from sheet2 in sheet3 - Column A.
Option Explicit
Sub test()
Dim rng As Range, c As Range, cfind As Range, mycell As Range, cfindRow As Range
On Error Resume Next
Worksheets("Sheet3").Cells.Clear
With Worksheets("Sheet2")
Set rng = .Range(.Range("A2"), .Range("a2").End(xlDown))
For Each c In rng
With Worksheets("Sheet1")
Set cfind = .Columns("A:A").Cells.Find _
(what:=c.Value, lookat:=xlWhole)
'Find method always returns Range; So the following line should be something If cfind is not Nothing OR cfind <> Nothing (Both the syntaxes are wrong. Suggest me the right syntax please.
If cfind = 1 Then
'Here please tell me how to reference a whole row based on Column A value
'Here using cfind and again using mycell is something wrong as mycell variable again compares rows in sheet2 with rows in sheet1 which include Question_Id too.
Set mycell = ActiveWorkbook.Worksheets("Sheet2").UsedRange.End(xlDown)
'My both the excelsheets have values from columns A to AD. Still I want to make the code for all used Ranges of columns instead of only A to AD.
Set cfindRow = Worksheets("Sheet1").Rows("A2:AD").Cells.Find _
(what:=mycell.Value, lookat:=xlWhole)
'Find method always returns Range; So the following line should be something If cfindRow is not Nothing OR cfindRow <> Nothing (Both the syntaxes are wrong. Suggest me the right syntax please.
If cfindRow = 1 Then
'MsgBox "Match Found" 'Right Now do Nothing
End If
Else
' mycell.Interior.Color = vbRed
' mydiffs = mydiffs + 1
'Copy the question numbers to sheet3 either if they are new in new sheet (Sheet2) or content against them (in the whole row-any column value) is changed.
cfind.Copy Worksheets("sheet3").Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)
End If
End With
Next c
Application.CutCopyMode = False
End With
MsgBox "Data Scrubbed Successfully..."
End Sub
Can someone tell me how to refer those ranges based on key column values?
My new approach towards solution:
(It may be a hint to give me answer on how to reference Row values based on key column)
Getting row indices of both the sheets; column A values
(Question_Id's) i.e.
c.Row and cfind.Row
Then
Check If(Sheet2.Cells(c.Row, Columns) = Sheet1.Cells(cfind.Row,
Columns) (To compare columns against matching Question_Ids only.)
So Finally this what all am trying to achieve :
1)Compare two sheets based on key column:
Pick up the Question_Id from Sheet2 - column A and compare it against column A in Sheet1. If the key columns from both the sheets match and also the contents against them(the complete row) matches- then Do nothing.
If the key column value(Question_Id - Column A) matches but values(Row) against it do not match them color those specific cells (Only cells) and not the whole row in Red background.
The Question_Id's which are there in sheet2 but not in sheet1 should be listed under first column in sheet3. Starting from A2.
The Question_Id's which are there in sheet1 but not in sheet2 should be listed under second column in sheet3. Starting from B2.
I am basing my code off of your first approach, because I found it simpler and more readable than the second approach.
We'll just do the most naive algorithm, which is to iterate through every row in the used range of both worksheets. (The fastest algorithm would probably be to sort both ranges in memory and then compare, but simplicity of code over performance optimization for now.)
Sub compareSheets(shtSheet1 As String, shtSheet2 As String)
Dim range1 As Range, range2 as Range
Dim mydiffs As Integer, row1 As Integer, row2 As Integer, col As Integer
Application.ScreenUpdating = False
'First create the two ranges we will be using
Set range1 = ActiveWorkbook.Worksheets(shtSheet1).UsedRange
Set range2 = ActiveWorkbook.Worksheets(shtSheet2).UsedRange
'Iterate through the rows of both ranges
For row1 = 1 To range1.Rows.Count
For row2 = 1 To range2.Rows.Count
'Only process the ranges if they share a common key in column 1
If range1.Cells(row1, 1) = range2.Cells(row2, 1) Then
'If they share the same key, iterate through columns and compare
For col = 1 To WorksheetFunction.Max(range1.Columns.Count, range2.Columns.Count)
If Not range1.Cells(row1, col).Value = range2.Cells(row2, col).Value Then
range1.Cells(row1, col).Interior.Color = vbRed
range2.Cells(row2, col).Interior.Color = vbRed
mydiffs = mydiffs + 1
End If
Next
End If
Next
Next
'Display no. of differences
MsgBox mydiffs & " differences found", vbInformation
Application.ScreenUpdating = True
End Sub
There are some specifications I wasn't sure of. For example, what if a key is in one spreadsheet but not the other? Should it be colored red in the sheet where it exists?
Nevertheless, I think the above code should give you a good start to address your more conceptual questions, and I'm happy to help adjust as needed, so please comment if there are specific requirements I'm missing.
Update 1
Here's the update code after our discussion in chat (link in comments), which takes the unmatched keys from the full outer join and copies them to a third sheet.
Sub compareSheets(shtSheet1 As String, shtSheet2 As String, shtSheet3 As String)
Application.ScreenUpdating = False
Dim range1 As Range, range2 As Range
Dim myDiffs As Integer, row1 As Integer, row2 As Integer, col As Integer
Dim sheet3index1 As Integer, sheet3index2 As Integer, i As Integer
Dim leftKeyMatched As Boolean 'Boolean to keep track of whether the key in sheet1 has a match as we are looping
Dim rightKeysMatched() As Boolean 'Array to keep track of which keys in sheet2 have matches
Set range1 = ActiveWorkbook.Worksheets(shtSheet1).UsedRange
Set range2 = ActiveWorkbook.Worksheets(shtSheet2).UsedRange
ReDim rightKeysMatched(range2.Rows.Count)
For row1 = 1 To range1.Rows.Count
leftKeyMatched = False
For row2 = 1 To range2.Rows.Count
If range1.Cells(row1, 1) = range2.Cells(row2, 1) Then
'We have a match, so mark both sides as matched
leftKeyMatched = True
rightKeysMatched(row2 - 1) = True 'This -1 is because the array indexing starts at 0 but the rows in the spreadsheet start at 1
For col = 1 To WorksheetFunction.Max(range1.Columns.Count, range2.Columns.Count)
If Not range1.Cells(row1, col).Value = range2.Cells(row2, col).Value Then
range1.Cells(row1, col).Interior.Color = vbRed
range2.Cells(row2, col).Interior.Color = vbRed
myDiffs = myDiffs + 1
End If
Next
End If
Next
'Print out the key from sheet1 if it didn't find a match in sheet2
If leftKeyMatched = False Then
sheet3index1 = sheet3index1 + 1
ActiveWorkbook.Worksheets(shtSheet3).Cells(sheet3index1, 1) = range1.Cells(row1, 1)
End If
Next
'Now print out any key that still hasn't been matched in sheet2
For i = 0 To range2.Rows.Count
If rightKeysMatched(i) = False Then
sheet3index2 = sheet3index2 + 1
ActiveWorkbook.Worksheets(shtSheet3).Cells(sheet3index2, 2) = range2.Cells(i + 1, 1) '+1 for same reason as above, index starts at 0 versus 1
End If
Next
'Display no. of differences
'MsgBox myDiffs & " differences found", vbInformation
Application.ScreenUpdating = True
End Sub
I'll take a crack at this
Sub compareSheets(shtSheet1 As String, shtSheet2 As String)
Dim mycell As Range
Dim mydiffs As Integer
Dim ws1 as WorkSheet
Dim ws2 as WorkSheet
Dim rng as Range
Dim SourceRow as integer
Dim Col as integer
set ws1 = ActiveWorkbook.Worksheets(shtSheet1)
set ws2 = ActiveWorkbook.Worksheets(shtSheet2)
myDiffs = 0
'Application.ScreenUpdating = false 'enable this later, once it's all working
'Color Uncommon records in Red Background
'your key is in column A, so we'll only loop through that column
For sourceRow = 1 to ws2.usedrange.Rows.Count
set rng = ws1.range(ws1.address).find(what:=ws2.cells(sourcerow, 1), LookIn:=xlValues, _
LookAt=xlWhole, MatchCase:=False)
'making an assumption on MatchCase, change as needed
if not rng is Nothing then 'we found the key, now let's look at the rest of the row
col = 2
'loop through the rest of the columns for this row
while col < ws2.usedRange.Columns.Count
'if the cell in the row we just found on sheet1 <> the cell that we were looking for from sheet2
if rng.cells(1,col) <> ws2.cells(sourcerow,col) then
rng.cells(1,col).Interior.Color = vbRed
mydiffs = mydiffs+1
end if
col = col + 1
wend
else
'we didn't find the key. pop up a msgbox. you may want something else
MsgBox ("Sheet2 key: " & ws1.value & " not found on Sheet1")
end if
'Display no. of differences
MsgBox mydiffs & " differences found", vbInformation
ActiveWorkbook.Sheets(shtSheet2).Select
MsgBox "Data Scrubbed Successfully..."
Application.ScreenUpdating = True
End Sub
If you want to find a value in a range use the following:
.Find(What, After, LookIn, LookAt, SearchOrder, SearchDirection, MatchCase, MatchByte, SearchFormat)
Like this :
Application.ScreenUpdating = False
'On Error Resume Next 'Err.Numbers 9, 91 => Find: value not found
Dim findCell as range
ActiveWorkbook.Worksheets(shtSheet2).Select
ActiveWorkbook.Worksheets(shtSheet2).UsedRange.Select
'Color Uncommon records in Red Background
For Each mycell In ActiveWorkbook.Worksheets(shtSheet1).UsedRange
Set findCell = Selection.Find(What:=Trim(mycell.value & ""), LookIn:=xlValues)
If findCell Is Nothing Then
mycell.Interior.Color = vbRed
mydiffs = mydiffs + 1
End If
Next
Note :
Please change Application.ScreenUpdating = True to Application.ScreenUpdating = False
And for more information use this MSDN article
And for using a function like that you want:
Public Function look_up_id (r as Range) As Variant
'
'Function body
'
End Function
'....
Call look_up_id(ActiveWorkbook.Worksheets(shtSheet2).Range("A:A", table))
'....