I want to select some range based on cells value, as they might be each time in different column.
So my first thought was something like below, but I'm not sure if that's the right way?
Sub RangeBetween()
Dim rng1 As Range, rng2 As Range
Dim totalRange As Range
Dim c1, c2 As Integer
c1 = 1
Do Until Name = "A"
Name = Cells(1, c1)
c1 = c1 + 1
Loop
someA= c1 - 1
c2 = 1
Do Until Name = "B"
Name = Cells(1, c2)
c2 = c2 + 1
Loop
someB= c2 - 1
Set rng1 = Range("???")
Set rng2 = Range("???")
Set totalRange = Range(rng1.Address & ":" & rng2.Address)
totalRange .Select
End Sub
Thanks
Or you can use Match()
Sub RangeBetween()
Dim totalRange As Range
Dim c1 As Long, c2 As Long
c1 = 0
c2 = 0
With Worksheets("Sheet1") 'Change to your worksheet
On Error Resume Next
c1 = Application.WorksheetFunction.Match("A", .Rows(1), 0)
c2 = Application.WorksheetFunction.Match("B", .Rows(1), 0)
On Error GoTo 0
If c1 > 0 And c2 > 0 Then
Set totalRange = .Range(.Cells(1, c1), .Cells(1, c2))
totalRange.Select
Else
MsgBox "One or both items not found in range"
End If
End With
End Sub
Related
I am trying to give a color to the entire row that is blank but only if above a specific text. The specific text is on column A. Struggling to find a code that i can use /modify, can you please help?
Sub Reformat()
Dim SrchRng3 As Range
Dim c3 As Range, f As String
Set SrchRng3 = Sheets("RAW DATA FILE").Range("B:B").End(xlUp))
Set c3 = SrchRng3.Find("Customer account", LookIn:=xlValues)
If Not c3 Is Nothing Then
f = c3.Address
Do
With Sheets("RAW DATA FILE").Range("A" & c3.Row & ":Q" & c3.Row)
.Interior.ColorIndex = 53
End With
Set c3 = SrchRng3.FindNext(c3)
Loop While c3.Address <> f
End If
End Sub
You were already pretty close, try this adjusted code:
Sub Reformat()
Dim SrchRng3 As Range, ws As Worksheet
Dim c3 As Range, f As String
Dim colorRange As Range
Set ws = Sheets("RAW DATA FILE")
Set SrchRng3 = ws.Range("A1", ws.Cells(Rows.Count, 1).End(xlUp))
Set c3 = SrchRng3.Find("Customer account", LookIn:=xlValues)
If Not c3 Is Nothing Then
f = c3.Address
Do
Set colorRange = ws.Range("A" & c3.Row - 1 & ":Q" & c3.Row - 1)
If WorksheetFunction.CountA(colorRange) = 0 Then colorRange.Interior.ColorIndex = 53
Set c3 = SrchRng3.FindNext(c3)
Loop While c3.Address <> f
End If
End Sub
In your original code you were looking for your specified string in column B, not column A.
So because I wasn't specific with my previous question I need your help again.
Basically, I asked if there's a way to find a range between some value/cells, because I was sure that when i will get that range this below will work (so I can select lets say "headers" of the columns with all the data below:
totalRange(Selection, Selection.End(xlDown)).Select
So one of you came up with help and provide code below, which is working just fine, but i'm not sure if I can use it in my case. Because as I said, what im trying to do is to first find a range between two cells in firstrow and then select all the data below with it. Something like on screenshot below.
I want to find Col7 and Col12 and then select the whole range below.
The problem is this Col7/Col12 range might start from different column in each file.
https://ibb.co/gtuvEb
Sub RangeBetween()
Dim totalRange As Range
Dim c1 As Long, c2 As Long
Dim r1 As Long, r2 As Long
r1 = 0
r2 = 0
c1 = 1
c2 = 1
With Worksheets("Sheet1") 'Change to your worksheet
c1 = 1
Do Until Name = "A"
Name = Cells(1, c1)
c1 = c1 + 1
Loop
c1 = c1 - 1
c2 = 1
Do Until Name = "B"
Name = Cells(1, c2)
c2 = c2 + 1
Loop
c2 = c2 - 1
On Error Resume Next
r1 = Application.WorksheetFunction.Match("A", .Columns(c1), 0)
r2 = Application.WorksheetFunction.Match("B", .Columns(c2), 0)
On Error GoTo 0
If r1 > 0 And r2 > 0 Then
Set totalRange = .Range(.Cells(r1, c1), .Cells(r2, c2))
totalRange.Select
Else
MsgBox "One or both items not found in range"
End If
End With
End Sub
Thanks for any suggestions.
Sub RangeBetween()
Dim totalRange As Range
Dim c1 As Long, c2 As Long
Dim r1 As Long
With Worksheets("Sheet1") 'Change to your worksheet
On Error Resume Next
'Find the Columns
c1 = Application.WorksheetFunction.Match("Col7", .Rows(1), 0)
c2 = Application.WorksheetFunction.Match("Col12", .Rows(1), 0)
On Error GoTo 0
If c1 > 0 And c2 > 0 Then
'Find last row with data
r1 = .Cells(.Rows.Count, c2).End(xlUp).Row
'Set the range to the whole
Set totalRange = .Range(.Cells(1, c1), .Cells(r1, c2))
totalRange.Select
Else
MsgBox "One or both items not found in range"
End If
End With
End Sub
It seems that you try to look up certain values in the headers and select the ones between those columns. If I understood correctly, your question this can help you.
Dim ws As Worksheet
Set ws = ThisWorkbook.Sheets("your sheet")
Dim header1 As Range, header2 As Range
On Error Resume Next
Set header1 = ws.Rows(1).Find(what:="your header value 1", LookIn:=xlValues,
lookat:=xlWhole)
Set header2 = ws.Rows(1).Find(what:="your header value 2", LookIn:=xlValues,
lookat:=xlWhole)
On Error GoTo 0
If Not header1 Is Nothing And Not header2 Is Nothing Then
Range(header1,
header2).EntireColumn.SpecialCells(xlCellTypeConstants).Select
Else:
MsgBox "Header not fount"
End If
I would appreciate your help with the following:
I would like to compare two columns, let us say Column A and Column B, **looking for duplicates**.
If a value in Column A has a match value in Column B, I would like to format the cells of the same duplicate value with the color (the colors are random and different for each match).
This is if `A12 = B30`, the color will be red. And if `A20 = B1`, the color is green and so on.
If there is no match just leave it as it.
That was only an example for red and green. let say you have two columns (A and B).
A1 = 1000
A2 = 2000
A3 = 3000
A4 = 4000
A5 = 5000
A6 = 6000
A7 = 7000
A8 = 8000
A9 = 9000
B1 = 1500
B2 = 9000
B3 = 5000
B4 = 3500
B5 = 7500
B6 = 1000
B7 = 4000
So you have several matches and I need each match to be in random different colors. For example:
A1 = B6 –> They will be colored/highlighted in green
A4 = B7 –> They will be colored/highlighted in red
A5 = B3 –> They will be colored/highlighted in yellow
A9 = B2 –> They will be colored/highlighted in pink
The colors will be different for any match and the non-match will be color less or no change.
I wish this will explain the question and this has to be using excel.
{
Sub UsingCollection()
Dim cUnique As Collection
Dim Rng As Range
Dim Cell As Range
Dim sh As Worksheet
Dim vNum As Variant for at
Dim LstRw As Long
Dim c As Range, clr As Long, x
Set sh = ActiveSheet
With sh
LstRw = .Cells(.Rows.Count, "A").End(xlUp).Row
Set Rng = .Range("A1:B" & LstRw)
Set cUnique = New Collection
Rng.Interior.ColorIndex = xlNone
clr = 3
On Error Resume Next
For Each Cell In Rng.Cells
cUnique.Add Cell.Value, CStr(Cell.Value)
Next Cell
On Error GoTo 0
For Each vNum In cUnique
For Each c In Rng.Cells
If c = vNum Then
x = Application.WorksheetFunction.CountIf(Rng, vNum)
If x > 1 Then c.Interior.ColorIndex = clr "error here: the code runs fine for around 50 lines then it is stoppedand gives error and pointing to this line"
//Error shows in pop window: Run-time error 'g': Subscript out of range
End If
Next c
clr = clr + 1
Next vNum
End With
End Sub
}
This is an adjusted code from my answer here.
https://stackoverflow.com/a/33798531/1392235
Loop through the cells to find the unique values, then loop through the unique values to color the duplicates.
Sub UsingCollection()
Dim cUnique As Collection
Dim Rng As Range
Dim Cell As Range
Dim sh As Worksheet
Dim vNum As Variant
Dim LstRw As Long
Dim c As Range, clr As Long, x
Set sh = ActiveSheet
With sh
LstRw = .Cells(.Rows.Count, "A").End(xlUp).Row
Set Rng = .Range("A1:B" & LstRw)
Set cUnique = New Collection
Rng.Interior.ColorIndex = xlNone
clr = 3
On Error Resume Next
For Each Cell In Rng.Cells
cUnique.Add Cell.Value, CStr(Cell.Value)
Next Cell
On Error GoTo 0
For Each vNum In cUnique
For Each c In Rng.Cells
If c = vNum Then
x = Application.WorksheetFunction.CountIf(Rng, vNum)
If x > 1 Then c.Interior.ColorIndex = clr
End If
Next c
clr = clr + 1
Next vNum
End With
End Sub
Results
Sample Workbook
EDIT:
Using colorindex limits us to 56 colors, if we use RGB we can increase that. Edit this part of the code, you will have to play with the values get the color variances you like.
If x > 1 Then c.Interior.Color = 1000000 + clr * 100
End If
Next c
clr = clr + 255
Hi there i have a similar question to the question posed at
Move from one cell to another and count the number of rows in between two data
In my example i would like count the number of rows between non-empty cells (including the original data line itself) in column A and put the count in Column B
My data starts at A1 and moves down with blanks in cells until the the next data row.
Example:
A1 1 B1 3
A2 B2 4
A3 B3 2
A4 2 B4 3
A5
A6
A7
A8 3
A9
A10 4
A11
A12
I tried to make mods to the original solution posted but i cant seem to get the count for the last row.
Any assistance would be very much appreciated.
Not sure if I quite get what your asking for but try something like this:
Private Sub CountSkips()
Dim lStart As Long, lEnd As Long
Dim rData As Range, rNext As Range
Dim vData As Variant
Set rData = ActiveSheet.Range("A1" _
, ActiveSheet.Cells(Application.Rows.Count, 1).End(xlUp))
vData = rData.Resize(rData.Rows.Count + 1).Value2
Set rNext = rData.Resize(1)
Do While rNext.Row <> Application.Rows.Count
lStart = rNext.Row
Set rNext = rNext.End(xlDown)
If LenB(vData(lStart + 1, 1)) = 0 Then
lEnd = rNext.Row
rNext.Offset(lStart - lEnd, 1) = lEnd - lStart
End If
Loop
End Sub
Update:
The other way to do it, from your comment it sounded like you want the number by the item after the blank.
Private Sub CountSkips()
Dim lStart As Long, lEnd As Long, lVeryLastRow As Long
Dim rData As Range, rNext As Range
Dim vData As Variant
lVeryLastRow = Application.Rows.Count
Set rData = ActiveSheet.Range("A1" _
, ActiveSheet.Cells(lVeryLastRow, 1).End(xlUp))
vData = rData.Resize(rData.Rows.Count + 1).Value2
Set rNext = rData.Resize(1)
Do While rNext.Row <> Application.Rows.Count
lStart = rNext.Row
Set rNext = rNext.End(xlDown)
If LenB(vData(lStart + 1, 1)) = 0 And rNext.Row <> lVeryLastRow Then
lEnd = rNext.Row
rNext.Offset(, 1) = lEnd - lStart
End If
Loop
End Sub
wsworkcenter--> workbook object name
WsWorkCenter.Activate
'counting non empty rows , will store count in the variable mlProjectCount
Cells(2, 1).Select
Selection.End(xlDown).Select
mlProjectCount = ActiveCell.Row
The code below is supposed to get the next record when a button is clicked in an input sheet.
My button is named CurrRecNew on sheet3 when I click it performs the code below but it doesn't appear to increment. Any suggestions on what I am doing wrong?
The datasheet sheet 1 has cells starting in Row A3 and going down eg
A3 1 B3 a
A4 Blank B4 b
A5 Blank B5 c
A6 2 B6 d
A7 Blank B7 f
A8 Blank B8 g
A9 Blank B9 h
A8 3 B10 ...
Sub ViewLogDown()
Dim historyWks As Worksheet
Dim InputWks As Worksheet
Dim lRec As Long
Dim lRecRow As Long
Dim lLastRec As Long
Dim LastRow As Long
Dim Rlen As Long
Dim lCurrentRow As Long
lCurrentRow = lCurrentRow + 1
Application.EnableEvents = False
Set InputWks = Worksheets("Sheet3")
Set historyWks = Worksheets("Sheet1")
With historyWks
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Offset(1, 0).Row - 1
lLastRec = LastRow - 1
End With
With InputWks
lCurrentRow = lCurrentRow + 1
lRec = .Range("CurrRecNew").Value
Do While Len(Cells(lCurrentRow, 1).Value) = 0
lCurrentRow = lCurrentRow + 1
Loop
lCurrentRow = lCurrentRow - 1
.OLEObjects("tbRiskID").Object.Value = historyWks.Cells(lCurrentRow, 1)
.OLEObjects("tbRiskContext").Object.Value = historyWks.Cells(lCurrentRow, 2)
.OLEObjects("TextBox34").Object.Value = historyWks.Cells(lCurrentRow, 3)
.OLEObjects("tbRiskEx").Object.Value = historyWks.Cells(lCurrentRow, 4)
.OLEObjects("tbRiskCat").Object.Value = historyWks.Cells(lCurrentRow, 5)
End With
Application.EnableEvents = True
End Sub
Your code is very confusing, you are finding the lCurrentRow on the InputWks sheet but then setting the textbox objects to the lcurrentrow on the Historywks sheet??? You need to explain clearly what each worksheet does, which sheet you want to find the next row on etc.
I presume that the you are using the named range CurrRecNew to store the current row. And you are wanting get the current row on the historywrks sheet. Therefore as far as finding the next row which is your actual question your code should look something like this:
Dim rFound As Range
'// History sheet
With historyWks
'// Get current row, you need to correctly define the sheet name which contains the CurrRecNew Range.
lCurrentRow = InputWks.Range("CurrRecNew").Value
Set rFound = .Columns(1).Find(What:="*", After:=.Cells(lCurrentRow, 1))
If Not rFound Is Nothing Then
If rFound.Row > lCurrentRow Then
lCurrentRow = rFound.Row
txtName.Text = Cells(lCurrentRow, 1).Value
txtPhone.Text = Cells(lCurrentRow, 2).Value
End If
End If
'// Once again correct the sheet name here I guessed CurrRecNew was on the InputWks sheet
InputWks.Range("CurrRecNew").Value = lCurrentRow
End with