So i'm stuck again with my limited knowledge of VBA script.
I have this script:
Sub new_Group()
Dim rnTarget As Range
Set rnTarget = Blad2.Cells(Range("A9:A44").Cells.Count, 1).End(xlUp)
If rnTarget <> "" Then Set rnTarget = rnTarget.Offset(1)
Blad1.Range("A7:F15").Copy
Blad2.Range(rnTarget.Address).PasteSpecial Paste:=xlPasteValues
Blad2.Range(rnTarget.Address).PasteSpecial Paste:=xlPasteFormats
Blad2.Range("P8").Value = Blad2.Range("P8").Value + 10
End Sub
It finds the first empty cell in the range of A9 to A44 and copys a premade number of cells in its place.
My question now is if it's possible to have it start looking in another range if no cell is empty in A9:A44?
I want it to first check from A9 to A44 for empty cells, if none is found then start looking in range H9 to H44 and so on.
I have tried:
Set rnTarget = Blad2.Cells(Range("A9:A44, H9:H44").Cells.Count, 1).End(xlUp)
But then it just kept going down the A column.
Do i have to make an Else in some way?
Sub new_Group()
If (new_asd("A") = True) Then
new_asd ("H")
End If
End Sub
Function new_asd(new_col As String) As Boolean
Dim rnTarget As Range
new_asd = False
If Blad2.Range(new_col & "44") = "" Then
Set rnTarget = Blad2.Cells(Range(new_col & "9:" & new_col & "44").Cells.Count, Range(new_col & 1).Column).End(xlUp)
If rnTarget <> "" Then
Set rnTarget = rnTarget.Offset(1)
Blad1.Range("A7:F15").Copy
Blad2.Range(rnTarget.Address).PasteSpecial Paste:=xlPasteValues
Blad2.Range("P8").Value = Blad2.Range("P8").Value + 10
Else
new_asd = True
End If
Else
new_asd = True
End If
End Function
Related
What I'm looking for is, I need to find out if a cell contains ".L" in it, if yes, the entire row along with 4 more rows needs to be deleted and this series goes on until last set of data.
For example:
There would be hundreds of dataset like shown below, out of which "RIC" contains ".L".
TID: xxx, Symbol=xxx, Date=xxx, RIC=EPWN.L , CUSIP=xxx, SEDOL=xxx
DataStream: xxxx
Bloomberg.: xxxx
Market....: xxxx
TID: xxx, Symbol=xxx, Date=xxx, RIC=BAR.BR , CUSIP=xxx, SEDOL=xxx
DataStream: xxx
Bloomberg.: xxx
Market....: xxx
Need to delete the entire set if any RIC is having ".L". So in the end, what should I get is dataset without ".L"
Please help
Below is the vba but it is not working:
Range("b2:b2000").ClearContents
Dim rng As Range
Dim cell As Range
Dim serchstring As String
Set rng = ActiveSheet.UsedRange
searchstring = ".l"
On Error Resume Next
For Each cell In rng
If UCase(cell.Value) Like "*" & UCase(searchstring) Then
cell.Offset(0, 1).Value = "NA"
cell.Offset(1, 1).Value = "NA"
cell.Offset(2, 1).Value = "NA"
cell.Offset(3, 1).Value = "NA"
cell.Font.Bold = True
cell.Interior.Color = vbYellow
End If
Next cell
Cells.Select
With ActiveSheet
.AutoFilterMode = False
.Range("A:B").AutoFilter
.Range("A:B").AutoFilter field:=2, Criteria1:="NA"
Intersect(.UsedRange, .UsedRange.Offset(1)).SpecialCells(xlCellTypeVisible).EntireRow.Delete
.AutoFilterMode = False
End With
With ActiveSheet
.AutoFilterMode = False
.Range("A:B").AutoFilter field:=1, Criteria1:=""
Intersect(.UsedRange, .UsedRange.Offset(1)).SpecialCells(xlCellTypeVisible).EntireRow.Delete
.AutoFilterMode = False
End With
If your program is not erasing the row, I think the issue lies with these lines:
cell.Offset(0, 1).Value = "NA"
cell.Offset(1, 1).Value = "NA"
cell.Offset(2, 1).Value = "NA"
cell.Offset(3, 1).Value = "NA"
Offset is returning a single cell so you are only erasing a single cell. But your post says you want to erase the whole row. To reference the row, I suggest:
cell.Offset(0, 1).EntireRow.ClearContents
cell.Offset(1, 1).EntireRow.ClearContents
cell.Offset(2, 1).EntireRow.ClearContents
cell.Offset(3, 1).EntireRow.ClearContents
Which can be reduced to a single line like:
cell.Offset(0).Resize(4).EntireRow.ClearContents
Or if you don't want to leave blank rows behind you can directly delete the rows like:
cell.Offset(0).Resize(4).EntireRow.Delete
But if you do repetitive deleting, you'll notice that Excel stutters and the execution is slow. So I suggest saving the rows to be deleted into a range variable and then deleting them all at once at the end. Use Union() to add ranges together.
If rToBeDeleted Is Nothing Then
Set rToBeDeleted = cell.Offset(0).Resize(4).EntireRow
Else
Set rToBeDeleted = Union(rToBeDeleted, cell.Offset(0).Resize(4).EntireRow)
End If
'And then at the end
rToBeDeleted.Delete
And if you do it this way, you don't need to do any of that autofilter deleting.
Edit:
For clarity, here is how I suggest your code be structured after applying my suggestions:
Range("b2:b2000").ClearContents
Dim rng As Range
Dim cell As Range
Dim rToBeDeleted As Range
Dim serchstring As String
Set rng = ActiveSheet.UsedRange
searchstring = "*.L"
On Error Resume Next
For Each cell In rng
If UCase(cell.Value) Like searchstring Then
If rToBeDeleted Is Nothing Then
Set rToBeDeleted = cell.Offset(0).Resize(4).EntireRow
Else
Set rToBeDeleted = Union(rToBeDeleted, cell.Offset(0).Resize(4).EntireRow)
End If
End If
Next cell
rToBeDeleted.Delete
I have a list of words in Sheet1 I need to match one by one from Sheets("Sheet2").Range("A1:A7500") until the end of the Range. Whenever word is matched I need to do something with it in Sheet1. That word occurs multiple times in Sheets("Sheet2").Range("A1:A7500").
Following code is Finding word only once. I dont understand where it is going wrong.
Sub XMAX()
Dim lrow As Long
Dim cel As Range
Dim oRng As Range: Set oRng = Sheets("Sheet2").Range("A1:A7500")
Dim oFoundRng As Range, oLastRng As Range
lrow = Sheets("sheet1").Cells(Sheets("Sheet1").Rows.Count, "f").End(xlUp).Row
'''''''''''''''Sheet1'''''''''''''''
For Each cel In Range("f4:f" & lrow)
If IsEmpty(cel.Value) = False Then
Set oFoundRng = oRng.find(cel.Value)
Do While Not oFoundRng Is Nothing
If UCase(oFoundRng.Offset(0, 1).Value) = "ISAAC" Then
Range("X" & cel.Row).Value = "X"
ElseIf UCase(oFoundRng.Offset(0, 1).Value) = "YO" Then
Range("V" & cel.Row).Value = "X"
ElseIf UCase(oFoundRng.Offset(0, 1).Value) = "JAN" Then
Range("U" & cel.Row).Value = "X"
Else
MsgBox oFoundRng.Value
End If
Set oLastRng = oFoundRng
Set oFoundRng = oRng.FindNext(cel.Value) 'Getting Error(1004) here "unable to get findnext property of the range class"
If oLastRng >= oFoundRng Then
Exit Do
End If
Loop
Else
End If
Next
Change this line
Set oFoundRng = oRng.FindNext(oFoundRng)
to
Set oFoundRng = oRng.FindNext
You are not searching for the word but for the range you previously found. You actually don't need to pass a value to .FindNext at all.
You also have to change this line
If oLastRng >= oFoundRng Then
to
If oLastRng.Row >= oFoundRng.Row Then
since the first line compares the values (which is not what you want to do since it will always evaluate to True). You actually want to compare the row numbers.
On another note, the following code snippet does not work:
If UCase(oFoundRng.Offset(0, 1).Value) = "ISAAC" Then
Range("X" & cel.Row).Value = "X"
ElseIf UCase(oFoundRng.Offset(0, 1).Value) = "ISAAC" Then
Range("W" & cel.Row).Value = "X"
This ElseIf will never be triggered since the condition is the same as the initial If condition.
You also don't need both of these statements:
Set oFoundRng = Nothing
Exit Do
They both achieve the same thing (breaking the loop), Exit Do does it more efficiently.
you may be after this (explanations in comments):
Sub XMAX()
Dim cel As Range
Dim oRng As Range: Set oRng = Sheets("Sheet2").Range("A1:A7500")
Dim oFoundRng As Range
Dim firstAddress As String
With Sheets("sheet1") ' reference "Sheet1" sheet
With .Range("f4", .Cells(.Rows.Count, "f").End(xlUp)) ' reference referenced sheet column "F" range from row 4 down to last not empty one
If WorksheetFunction.CountA(.Cells) > 0 Then ' if there's at least one not empty cell
For Each cel In .SpecialCells(xlCellTypeConstants) ' loop through referenced range not empty cells
Set oFoundRng = oRng.Find(what:=cel.Value, LookIn:=xlValues, lookat:=xlWhole) ' always specify at least 'LookIn' and 'LookAt' parameters, or they will be set as per last 'Find()' usage (even from Excel UI!)
If Not oFoundRng Is Nothing Then ' if a match found
firstAddress = oFoundRng.Address ' store first matched cell address
Do
Select Case UCase(oFoundRng.Offset(0, 1).Value2)
Case "ISAAC"
.Range("X" & cel.Row).Value = "X"
Case "YO"
.Range("V" & cel.Row).Value = "X"
Case "JAN"
.Range("U" & cel.Row).Value = "X"
Case Else
MsgBox oFoundRng.Value
End Select
Set oFoundRng = oRng.FindNext(oFoundRng) ' search for next occurrence
Loop While oFoundRng.Address <> firstAddress ' exit do when hitting fisr found cell again
End If
Next
End If
End With
End With
End Sub
I am trying to write a macro that hides the row if the cell value equals the next visible cell in that column and loops through the whole column. I have read that SpecialCells(xlCellTypeVisible) only works up to 8192 cells and my spreadsheet has 15,000 rows.
I have tried something like this but want to restrict it to only visible cells
Sub Test()
For i = 7 To 15258
If Range("P" & i).Value = Range("P" & i + 1).Value Then
Rows(i).Hidden = True
End If
Next i
End Sub
I have tried to search for a solution but haven't been able to find one yet.
Thanks!
I'd be surprised if this couldn't be optimized just a little bit, but it will work for what you are needing.
You can follow the comments within the code itself to kind of get a sense of what it's doing, but in a nutshell, you are using a For...Next statement to loop through your visible cells. For each visible cell, you will search for the next visible cell and then check to see if that matches. If it does, you add that cell to a special range that tracks all the rows to hide at the end of the code, then hide it.
Sub Test()
Dim ws As Worksheet, lookupRng As Range, rng As Range, lstRow As Long
Set ws = ThisWorkbook.Worksheets(1)
lstRow = 15258
Set lookupRng = ws.Range("P7:P" & lstRow)
Dim rngToHide As Range, i As Long
For Each rng In lookupRng.SpecialCells(xlCellTypeVisible)
Application.StatusBar = "Checking row " & rng.Row & " for matches."
For i = rng.Row + 1 To lstRow 'Loop through rows after rng
If Not ws.Rows(i).Hidden Then 'Check if row is hidden
If rng.Value = ws.Cells(i, "P") Then 'check if the non-hidden row matches
If rngToHide Is Nothing Then 'Add to special range to hide cells
Set rngToHide = ws.Cells(i, "P")
Else
Set rngToHide = Union(rngToHide, ws.Cells(i, "P"))
End If
End If
Exit For 'Exit the second For statement
End If
Next i
Next rng
Application.StatusBar = "Hiding duplicate rows"
If Not rngToHide Is Nothing Then rngToHide.EntireRow.Hidden = True
Application.StatusBar = False
End Sub
I have the following code to find the first blank cell and sum the data below it at the last blank cell.
Dim r As Range
Dim lngRowStart As Long
If Range("A1").Formula <> "" Then
lngRowStart = 1
Else
lngRowStart = Range("A1").End(xlDown).Row
End If
Set r = Cells(lngRowStart, 1).End(xlDown).Offset(1, 0)
If Left(r.Offset(-1, 0).Formula, 1) <> "=" Then
r.FormulaR1C1 = "=Subtotal(9,R[-" & r.Row - lngRowStart & "]C:R[-1]C)"
End If
But this assumes that the data is in column A and for the first set of continuous data, how to modify it for any active cell to sum the above continuous data?
For example:
2
4
3
Blank (SUM ABOVE=9)
1
3
2
Blank (SUM ABOVE=6)
You can use the UDF below (explanation inside the code's comments):
Function SumContinRange(CurCell As Range) As Double
Dim RngStart As Range, SumRng As Range
If CurCell <> "" Then
' find the first empty cell using the Find function
Set RngStart = Columns(CurCell.Column).Find(what:="", After:=CurCell, LookIn:=xlValues)
Else
' find the first empty cell using the Find function
Set RngStart = Columns(CurCell.Column).Find(what:="", After:=CurCell, LookIn:=xlValues, SearchDirection:=xlPrevious)
End If
' set the Sum Range
Set SumRng = Range(RngStart.Offset(-1, 0), RngStart.Offset(-1, 0).End(xlUp))
SumContinRange = WorksheetFunction.Sum(SumRng) ' return this value
End Function
Then, test it by passing the ActiveCell using the Sub below:
Sub TestFunc()
If ActiveCell.Value <> "" Then
ActiveCell.End(xlDown).Offset(1) = SumContinRange(ActiveCell)
Else
ActiveCell = SumContinRange(ActiveCell)
End If
End Sub
Consider the following table:
What I would like to be able to do is create something like on the right hand side. This essentially requires telling Excel to sum all values for which the cell is zero until it encounters a 1, at which point it should begin the count again. I imagine this can be done using VBA, so I just need to determine how to actually set up that code. I imagine that the building blocks should be something like this:
Dim row As Long
Dim sum As List
row = Excel row definition
While ColB <> ""
If ColB.value = 0
Append ColC.value to Sum
Else Do Nothing
row = row + 1
Loop
Any help with the structure and syntax of the code would be much appreciated.
Try this:
Sub test()
Dim cel As Range, sRng As Range, oRng As Range, Rng As Range
Dim i As Long: i = 1
On Error GoTo halt
With Sheet1
.AutoFilterMode = False
Set Rng = .Range("B1", .Range("B" & .Rows.Count).End(xlUp))
Rng.AutoFilter 1, 0
Set sRng = Rng.Offset(1, -1).Resize(Rng.Rows.Count - 1) _
.SpecialCells(xlCellTypeVisible)
Rng.AutoFilter 1, 1
Set oRng = Rng.Offset(1, 0).SpecialCells(xlCellTypeVisible)
.AutoFilterMode = False
End With
If sRng.Areas.Count >= oRng.Areas.Count Then i = 2
For Each cel In oRng.Areas
If i > sRng.Areas.Count Then Exit For
If cel.Cells.Count = 1 Then
cel.Offset(0, 1).Formula = _
"=SUM(" & sRng.Areas(i).Address(True, True) & ")"
Else
cel.Cells(cel.Cells.Count).Offset(0, 1).Formula = _
"=SUM(" & sRng.Areas(i).Address(True, True) & ")"
End If
i = i + 1
Next
Exit Sub
halt:
Sheet1.AutoFilterMode = False
End Sub
Edit1:
Above works regardless of how many zero's or one's you have in Column B.
If error occurs, it will exit. I leave the coding on how you want the error handled.