I have the following Sub, which works fine if the range it's covering is fewer than 88 cells, otherwise it fails around the 88th iteration.
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Target.Count = 1 And Target.Row >= 3 And Target.Row <= 30 And Target.Column >= 17 And Target.Column < 22 Then
i = Target.Row
Dim MergeGroups As Range
Dim GroupTable As Range
Dim rngStart As Range
Dim rngEnd As Range
Dim rngToCount As Range
Dim CurrentGrp As Range
Dim NextGrp As Range
Dim NumVals As Integer
Set MergeGroups = Range("A1:O1")
Set GroupTable = Range("Q2:V2")
Set CurrentGrp = Range(Cells(GroupTable.Row, ActiveCell.Column).Address)
Set NextGrp = Range(Cells(GroupTable.Row, ActiveCell.Column + 1).Address)
Set rngStart = MergeGroups.Find(CurrentGrp.Value)
Set rngEnd = MergeGroups.Find(NextGrp.Value)
Set rngToCount = Range(Cells(ActiveCell.Row, rngStart.Column), Cells(ActiveCell.Row, rngEnd.Column - 1))
' rngToCount.Font.Bold = True
NumVals = Application.WorksheetFunction.CountA(rngToCount)
Cells(i, ActiveCell.Column).Value = NumVals
ActiveCell.Offset(1, 0).Select
Do While ActiveCell.Column < 21
ActiveCell.Offset(-28, 1).Select
Loop
End If
End Sub
It's an object in one specific worksheet, making use of the SelectionChange event. When it fails, I get the error message:
Run-time error '-2147417848 (80010108)': Method 'Find' of object 'Range' failed.
The issue is with the line:
Set rngStart = MergeGroups.Find(CurrentGrp.Value)
Can anyone help me work out why the Sub runs fine for small ranges, but otherwise fails around a particular iteration?
Credit to #Mat's Mug for telling me what was wrong, and this Q&A for helping me put it right. This is the modified code:
Sub PleaseWorkThisTime()
Dim MergeGroups As Range
Dim GroupTable As Range
Dim GrpCounts As Range
Dim rngStart As Range
Dim rngEnd As Range
Dim rngToCount As Range
Dim CurrentGrp As Range
Dim NextGrp As Range
Dim NumVals As Integer
Set MergeGroups = Range("A1:O1")
Set GroupTable = Range("Q2:V2")
Set GrpCounts = Range("Q3:U23")
Dim GrpCount As Range
For Each GrpCount In GrpCounts
Set CurrentGrp = Range(Cells(GroupTable.Row, GrpCount.Column).Address)
Set NextGrp = Range(Cells(GroupTable.Row, GrpCount.Column + 1).Address)
Set rngStart = MergeGroups.Find(CurrentGrp.Value)
Set rngEnd = MergeGroups.Find(NextGrp.Value)
Set rngToCount = Range(Cells(GrpCount.Row, rngStart.Column), Cells(GrpCount.Row, rngEnd.Column - 1))
NumVals = Application.WorksheetFunction.CountA(rngToCount)
GrpCount.Value = NumVals
Next GrpCount
End Sub
Related
I have an input table in range A2: D6, I want each value in input range to be shown 4 times in output
range A8: D27
Below is the code it is copying only one value to the output range.
Could you please guide me on how to change this VBA code to get the desired result as shown in the below picture.
Sub RepeatData()
Dim Rng As Range
Dim lr As Integer
Dim C As Integer
Range(("A8"), Range("D10000")).ClearContents
lr = Range(("A1"), Range("A2").End(xlDown)).Count
C = 4
Dim InputRng As Range, OutRng As Range
Set InputRng = Range("A2", Range("d" & lr))
Set OutRng = Range("a8")
For Each Rng In InputRng.Rows
xValue = Rng.Range("A1", "a1").Value
xNum = 4 ' No. of times to repeat
OutRng.Resize(xNum, C).Value = xValue
Set OutRng = OutRng.Offset(xNum, 0)
Next
End Sub
I can see that you are looping through entire input rows, so I would propose a solution copying entire rows.
Sub RepeatData()
Dim inputWorksheet As Worksheet
Dim inputRange As Range
Dim outputRangeStart As Range
Dim rowToBeCopied As Range
Dim firstFreeRow As Range
Dim numberOfOutputRows As Integer
Dim outputRange As Range
' set all params
Set inputWorksheet = Sheet1
Set inputRange = inputWorksheet.Range("A2:D5")
Set outputRangeStart = inputWorksheet.Range("A8")
numberOfOutputRows = 4
' clean output range
Range(outputRangeStart, outputRangeStart.End(xlDown).End(xlToRight)).ClearContents
' copy values
For Each rowToBeCopied In inputRange.Rows
Set firstFreeRow = FindFirstFreeCell(outputRangeStart)
Set outputRange = ExtendRangeByNumberOfRows(firstFreeRow, numberOfOutputRows)
rowToBeCopied.Copy
outputRange.PasteSpecial xlPasteValues
Next rowToBeCopied
End Sub
Function FindFirstFreeCell(startFrom As Range) As Range
If IsEmpty(startFrom) Then
Set FindFirstFreeCell = startFrom
ElseIf IsEmpty(startFrom.Offset(1, 0)) Then
Set FindFirstFreeCell = startFrom.Offset(1, 0)
Else
Set FindFirstFreeCell = startFrom.End(xlDown).Offset(1, 0)
End If
End Function
Function ExtendRangeByNumberOfRows(rangeToBeExtended As Range, numberOfRows As Integer) As Range
Set ExtendRangeByNumberOfRows = Range(rangeToBeExtended, rangeToBeExtended.Offset(numberOfRows - 1, 0))
End Function
I have a problem in a small part of my code : I want it to select the cells starting from c which is a cell meeting a condition that I have defined earlier, to the end of the list. In this range, I want it to copy the first value that exceeds resultat (a value obtained before).
With Worksheets("Feuil1").Range("A2:A5181")
Set c = .Find(Worksheets("Feuil2").Range("A14").Value, LookIn:=xlValues)
If Not c Is Nothing Then
firstAddress = c.Address
Do
Range(Range(c), Range(c).End(xlDown)).Select
If c Is Nothing Then
GoTo DoneFinding
End If
Loop While c.Address <> firstAddress
End If
DoneFinding:
End With
Dim c As Range
Dim firstAddress As String
Dim resultat As Double
Dim Cel As Range
Dim firstValue As Integer
Dim s1 As String, s2 As String
s1 = Worksheets("Feuil2").Range(c)
s2 = Worksheets("Feuil1").Range(s1).End(xlDown)
Worksheets("Feuil1").Range(s1 & ":" & s2).Select
For Each Cel In Range(s1 & ":" & s2)
If Cel.Value >= resultat Then
firstValue = Cel.Value
firstAddress = Cel.Address
Exit For
End If
Next
Worksheets("Feuil1").firstValue.Copy
Range("C14").Worksheet("Feuil2").PasteSpecial
I get an error for the 2 first lines of the code.
Thanks a lot for your help.
This is my new code, because I realized something is missing.. The SearchRange does not start from row 2, but from the row where the value (a date) is equal to the last date of ws2. I get an error for my For each line. It says Object required.
Edit - New code, object error at rangyrange :
Private Sub CommandButton1_Click()
Dim rangyrange As Range
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim foundRange As Range
Dim searchRange As Range
Dim lastRow As Long
Dim ws1Cell As Range
Dim firstAddress As String
Dim Cel As Range
Dim firstValue As Double
Dim A15Value As Date
Dim firsty As Long
Dim newRange As Range
Dim lastRow2 As Long
Set ws1 = Excel.Application.ThisWorkbook.Worksheets("Feuil1")
Set ws2 = Excel.Application.ThisWorkbook.Worksheets("Feuil2")
A15Value = CDate(ws2.Cells(15, 1).Value)
With ws1
lastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
lastRow2 = .Cells(.Rows.Count, 2).End(xlUp).Row
Set foundRange = ws1.Range(.Cells(2, 1), .Cells(lastRow, 1))
Set searchRange = foundRange.Find(A15Value, LookIn:=xlValues)
Set rangyrange = ws1.Range(.Cells(searchRange.Row, 1), .Cells(lastRow, 1))
firsty = rangyrange.Rows(1).Row
Set newRange = ws1.Range(.Cells(firsty, 2), .Cells(lastRow2, 2))
End With
For Each ws1Cell In newRange
If ws1Cell.Value >= resultat Then
firstValue = ws1Cell.Value
firstAddress = ws1Cell.Address
Exit For
End If
Next
ws2.Cells(15, 3).Value = firstValue
End Sub
Dim c As Range
Worksheets("Feuil1").Range(Worksheets("Feuil1").Range(c), Worksheets("Feuil1").Range(c).End(xlDown))
You haven't set c to a range, so VBA doesn't understand what you're doing.
Also, I suggest defining a worksheet variable to increase the readability of your code like this:
Set ws = Excel.Application.Worksheets("Feuil1")
And your statement becomes much more legible:
ws.Range(ws.Range(c), ws.Range(c).End(xlDown))
This is not how you reference a range, also, I would suggest never using .Select.
Range(s1 & ":" & s2).Select
This is how you reference a range:
'this is my preferred method of referencing a range
Set someVariable = ws.Range(ws.Cells(row, column), ws.Cells(row, column))
Or...
'this is useful in some instances, but this basically selects a cell
Set someVariable = ws.Range("B2")
Or...
'this references the range A1 to B1
Set someVariable = ws.Range("A1:B1")
Also, as #BigBen pointed out, you cannot set a range like so:
Dim c As Range
s1 = Worksheets("Feuil2").Range(c)
The reasons being:
c hasn't been assigned.
You can't use a range as an input unless it's of the form ws.Range(ws.Cells(row, column), ws.Cells(row, column))
Per your update that includes the assignment for c:
I get an error for the 2 first lines of the code.
This is because you're assigning c before you're declaring c.
You should have all of your Dim statements preceding your actual code (unless you know what you're doing) like so:
Public Sub MySub()
Dim c As Range
Dim firstAddress As String
Dim resultat As Double
Dim Cel As Range
Dim firstValue As Integer
Dim s1 As String, s2 As String
`the rest of your code
End Sub
I would change your Do loop to the following:
With Worksheets("Feuil1").Range("A2:A5181")
Set c = .Find(Worksheets("Feuil2").Range("A14").Value, LookIn:=xlValues)
If Not c Is Nothing Then
firstAddress = c.Address
Do While c.Address <> firstAddress
'I'm unsure of the goal here, so I'm ignoring it
Range(Range(c), Range(c).End(xlDown)).Select
If c Is Nothing Then
Exit Do
End If
Loop
End If
End With
Mainly because I hate GoTo statements and because the MS doc for Do loops states to use either Do While or Do Until instead of Loop While or Loop Until
s1 and s2 are strings, so you can't do this:
s1 = Worksheets("Feuil2").Range(c)
s2 = Worksheets("Feuil1").Range(s1).End(xlDown)
I'm assuming you want to get the column and row of c and iterate through that, but the problem is that you're working in 2 different worksheets, which you can't do. I'll assume it's an error and that you want to work on the "Fueil2" worksheet, so here goes:
Dim ws2 As Worksheet
Dim startCell As Range
Dim endCell As Range
Dim foundRange As Range
Set ws2 = Excel.Application.ThisWorkbook.Worksheets("Fueil2")
With ws2
Set startCell = .Cells(c.Row, c.Column)
Set endCell = .Cells(c.End(xlUp).Row, c.Column)
Set foundRange = .Range(.Cells(c.Row, c.Column), .Cells(c.End(xlUp).Row, c.Column))
For Each Cel In foundRange
'yada yada yada
End With
Post-lunch Edit:
It seems that this is a bit misleading because I tested this snippet and it works:
Public Sub test()
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim foundRange As Range
Dim searchRange As Range
Dim workRange As Range
Dim foundColumn As Range
Dim ws1LastCell As Range
Dim ws1Range As Range
Dim iWantThis As Range
Set ws1 = Excel.Application.ThisWorkbook.Worksheets("Sheet1")
Set ws2 = Excel.Application.ThisWorkbook.Worksheets("Sheet2")
Set searchRange = ws1.Range("A1:F1")
Set foundRange = searchRange.Find(ws2.Range("C1").Value, LookIn:=xlValues)
With foundRange
'last cell in the ws1 column that's the same column as foundRange
Set ws1LastCell = ws1.Range(ws1.Cells(.Row, .Column), ws1.Cells(ws1.Rows.Count, .Column)).End(xlDown)
'the range you want
Set iWantThis = ws1.Range(foundRange, ws1LastCell)
'check to see if it got what i wanted on ws1
iWantThis.Select
End With
End Sub
New Edit:
Public Sub test()
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim c14Value As Double
Dim searchRange As Range
Dim lastRow As Long
Dim ws1Cell As Range
Set ws1 = Excel.Application.ThisWorkbook.Worksheets("Sheet1")
Set ws2 = Excel.Application.ThisWorkbook.Worksheets("Sheet2")
'gets the date
A14Value = CDate(ws2.Cells(14, 1).Value)
With ws1
'gets the last row's number in column A on worksheet 1
lastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
'selects from A2 to the last row with data in it. this works only if
'there aren't any empty rows between your data, and that's what i'm assuming.
Set searchRange = .Range(.Cells(2, 1), .Cells(lastRow, 1))
End With
For Each ws1Cell In searchRange
If CDate(ws1Cell.Value) >= A14Value Then
'i didnt make a variable for firstValue
firstValue = ws1Cell.Value
'i didnt make a variable for firstAddress
firstAddress = ws1Cell.Address
Exit For
End If
Next
'puts firstValue into cell C14 on ws2
ws2.Cells(14, 3).Value = firstValue
End Sub
Until I see a definition for resultat, I'm assuming it's 100% correctly declared and assigned. hint: You should give us your declaration and assignment of resultat because I can't fully determine if how you defined resultat is an issue.
I have a noncontiguous range and I want whatever the user writes in each cell in the range to show up in a column in a table I made. In the first column of my table I'm having the program number each generated entry in the table when the user adds a value in one of the specified cells all the way up to 18. I renamed each cell in the range to be "Space_ (some number)". Even though I have written in three of the specified cells, my table only shows me the first value in the first specified cell.
Here is my code so far:
Sub test2()
Dim wb As Workbook: Set wb = ThisWorkbook
Dim ws As Worksheet: Set ws = wb.Sheets("Sheet1")
Dim i As Integer
Dim rng As Range
Set rng = ws.Range("Space_7, Space_10, Space_13, Space_16, Space_19, Space_22, Space_25, Space_28, Space_31, Space_34, Space_37, Space_40, Space_53, Space_56, Space_59, Space_62, Space_65, Space_68")
ws.Range("A13:A31,B13:B31").ClearContents
For i = 1 To 18
If Not IsEmpty("rng") Then
ws.Range("A12").Offset(1).Value = i
End If
Exit For
Next i
If Not IsEmpty("rng") Then
ws.Range("B12").Offset(1).Value = rng.Value
End If
End Sub
This should address the various issues I mentioned in my comment:
Sub test2()
Dim wb As Workbook: Set wb = ThisWorkbook
Dim ws As Worksheet: Set ws = wb.Sheets("Sheet1")
Dim i As Long
Dim rng As Range, r As Range
With ws
Set rng = .Range("Space_7, Space_10, Space_13, Space_16, Space_19, Space_22, Space_25, Space_28, Space_31, Space_34, Space_37, Space_40, Space_53, Space_56, Space_59, Space_62, Space_65, Space_68")
.Range("A13:B31").ClearContents
For Each r In rng.Areas
If Not IsEmpty(r) Then
.Range("A13").Offset(i).Value = i + 1
.Range("B13").Offset(i).Value = r.Value
i = i + 1
End If
Next r
End With
End Sub
A couple things here - Instead of trying to put all your named ranges into a Range, put them individually in an Array and cycle through them - If they're not blank, put the value into the cell.
Your .Offset is always going 1 below row 12, so that's why you're only seeing one row of data.
Sub test2()
Dim wb As Workbook: Set wb = ThisWorkbook
Dim ws As Worksheet: Set ws = wb.Sheets("Sheet1")
Dim i As Long, j As Long
Dim rngarray As Variant
rngarray = Array("Space_7", "Space_10", "Space_13", "Space_16", "Space_19", "Space_22", "Space_25", "Space_28", "Space_31", "Space_34", "Space_37", "Space_40", "Space_53", "Space_56", "Space_59", "Space_62", "Space_65", "Space_68")
j = 12
ws.Range("A13:B31").ClearContents
For i = 0 To UBound(rngarray)
If ws.Range(rngarray(i)).Value <> "" Then
ws.Range("A12").Offset(j - 11).Value = i + 1
ws.Range("B12").Offset(j - 11).Value = ws.Range(rngarray(i)).Value
j = j + 1
End If
Next i
End Sub
I'd go as follows:
Sub test2()
Dim i As Integer
Dim rng As Range, cell As Range
With ThisWorkbook.Sheets("Sheet1")
.Range("A13:A31,B13:B31").ClearContents
Set rng = .Range("Space_7, Space_10, Space_13, Space_16, Space_19, Space_22, Space_25, Space_28, Space_31, Space_34, Space_37, Space_40, Space_53, Space_56, Space_59, Space_62, Space_65, Space_68")
For Each cell In rng.SpecialCells(xlCellTypeConstants).Areas
ws.Range("A12:B12").Offset(i).Value = Array(i + 1, cell(1, 1).Value)
i = i + 1
Next
End With
End Sub
In the following code, when I get to for each curCell in Range(i) it is not able to understand the Range that I am referencing. I receive a Method 'Range' of Object'_worksheet' failed. I know the current Range(i) is incorrect, but I have tried every variation and nothing seems to work.
Can someone please help me understand how to get my code to recognize Range1, then Range2, etc?
Sub Worksheet_Change(ByVal Target As Range)
Dim Range1 As Range, Range2 As Range, Range3 As Range, Range4 As Range
Dim curCell As Variant
Dim i As Integer
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets(cCostingQSheet)
Set Range1 = ws.Range("E6:E9")
Set Range2 = ws.Range("E15:E19")
Set Range3 = ws.Range("E21")
Set Range4 = ws.Range("E23")
For i = 1 To 4
For Each curCell In Range(i).Cells
If Not WorksheetFunction.IsNumber(curCell) = True Then
curCell.Value = 0
Else
End If
Next
Next
End Sub
You need to use an array if you want a setup like that. Here's how:
Replace your variable declaration statement
'Instead of your original
'Dim Range1 As Range, Range2 As Range, Range3 As Range, Range4 As Range
'Use this:
Dim arrRanges(1 To 4) As Range
Then change how you set the ranges:
Set arrRanges(1) = ws.Range("E6:E9")
Set arrRanges(2) = ws.Range("E15:E19")
Set arrRanges(3) = ws.Range("E21")
Set arrRanges(4) = ws.Range("E23")
And when you loop through them, it looks like this:
For Each curCell In arrRanges(i).Cells
You could assign an non-contiguous range to a range variable instead of using either 4 different range variables or an array of ranges (as #tigeravatar suggested in their excellent answer). Something like this:
Sub test()
Dim R As Range
Dim myCell As Range
Dim ws As Worksheet
Dim i As Long
Set ws = ActiveSheet
Set R = ws.Range("E6:E9,E15:E19,E21,E23")
i = 1
For Each myCell In R.Cells
myCell.Value = i
i = i + 1
Next myCell
End Sub
I would go a step further and
Look at each range inside the overall range.
use a variant array to process the range (where the range area is more than one cell), then dump back to the range.
code
Sub recut()
Dim rng1 As Range
Dim rng2 As Range
Dim lngCol As Long
Dim lngRow As Long
Dim ws As Worksheet
Set ws = ActiveSheet
Set rng1 = ws.Range("E6:E9,E15:E19,E21,E23")
For Each rng2 In rng1.Areas
If rng2.Cells.Count > 1 Then
x = rng2.Value
For lngRow = 1 To UBound(x)
For lngCol = 1 To UBound(x, 2)
If IsNumeric(x(lngRow, lngCol)) Then x(lngRow, lngCol) = 0
Next
Next
rng2.Value2 = x
Else
If IsNumeric(rng2.Value) Then rng2.Value = 0
End If
Next rng2
End Sub
This is a continuation of the discussion Looping through values in cells to replace in the text
The following code take the value in cell D2 and populates its value in the OriginalText in all instances where the word "tagname" is used.
Then it loops through the loopText range and produces the correctedText range.
I am looking to use Do UntilEmpty command loop so that the loopText range depends on the user range input, say if the user populates cells D2:D54 then all of then are executed.
Below is my code, but I keep getting a run-time error '91'
Object variable or With block variable not set
Please, help.
Thanks.
Sub CommandButton21_Click()
Dim correctedText As Range
Dim OriginalText As Range
Dim loopText As Range
Dim i As Long
Dim cel As Range
Dim cel2 As Range
Do Until IsEmpty(loopText.Value)
Set correctedText = Range("B10")
Set OriginalText = Range("H3:H20")
Set loopText = Range("D2")
i = 0
Columns(2).Clear
For Each cel2 In loopText
For Each cel In OriginalText
correctedText.Offset(i).Value = Replace(cel.Value, "tagname", cel2.Value)
i = i + 1
Next cel
Next cel2
Loop
End Sub
Try this:
You only need the two loops, The first loop was changed to do what you are looking for.
Sub CommandButton21_Click()
Dim correctedText As Range
Dim OriginalText As Range
Dim loopText As Range
Dim i As Long
Dim cel As Range
Dim cel2 As Range
Dim j As Long
Set correctedText = Range("B10")
Set OriginalText = Range("H3:H20")
Set loopText = Range("D2")
i = 0
j = 0
Columns(2).Clear
Do Until IsEmpty(loopText.Offset(j).Value)
For Each cel In OriginalText
correctedText.Offset(i).Value = Replace(cel.Value, "tagname", loopText.Offset(j).Value)
i = i + 1
Next cel
j = j + 1
Loop
End Sub