Having very huge excel data. I want to copy the data from column C to other sheet with condition. C column having n number of text values want to take only which word contains less than 100 times repeatedly.
Sub DelR()
Dim myRow As Range
Dim to Delete As Range
For I=2 to 10000
If workseets("Sheet1").Cells(I,2) >100 Then
Set myRow = Worksheets("Sheet1").Rows(I)
If toDelete = myRow Else
Set to Delete = Union(toDelete, myRow)
End If
End If
Next I
If Not toDelete Is Nothing Then toDelete.EntireRow.Delete
End Sub
Sub DelR()
Dim sht As WorkSheet
Dim myRow As Range
Dim to Delete As Range
Set sht = worksheets("Sheet1")
For I=2 to 10000
If Application.Countif(sht.Columns(2), _
sht.Cells(I,2).Value) >100 Then
Set myRow = sht.Rows(I)
If toDelete Is Nothing
Set toDelete = myRow
Else
Set toDelete = Application.Union(toDelete, myRow)
End If
End If
Next I
If Not toDelete Is Nothing Then toDelete.EntireRow.Delete
End Sub
Related
Excel 2019
Windows 10
Using VBA I Need to set the row height to 18 but for only rows that have data
I have tried variations on the following
Sub UsedRowsHeight1()
ActiveWorkbook.Worksheets("Titles Data").Range("A" & Rows.Count).End(xlUp).RowHeight = 18
End Sub
and
Sub UsedRowsHeight2()
Rows().AutoFit
Rows.End(xlUp).RowHeight = 18
End Sub
None do what I am looking for.
use this:
Sub UsedRowsHeight1()
lr = Sheets("Titles Data").UsedRange.Rows(Sheets("Titles Data").UsedRange.Rows.Count).Row
Sheets("Titles Data").Range("1:" & lr).RowHeight = 18
End Sub
this uses special cells to select rows that have data (so if you have empty rows between filled rows they will not be affected)
Sub ChangeRowHeight()
Dim rngConst As Range
Set rngConst = Cells.SpecialCells(xlCellTypeConstants, 23)
Dim rngForm As Range
Set rngForm = Cells.SpecialCells(xlCellTypeFormulas, 23)
Union(rngConst, rngForm).RowHeight = 18
End Sub
Please, use the next way:
If you need/want setting the row height for all used range, even if there are empty rows in between, please, use the next code:
Sub RowHeightForRowsForUsedRange()
Dim sh As Worksheet, lastR As Long
Set sh = ActiveSheet
lastR = sh.Range("A" & sh.rows.count).End(xlUp).Row
sh.Range("A1:A" & lastR).RowHeight = 18
End Sub
To hide only rows of the used range having at least a cell with data on the row, please use the next version. In order to be fast, it uses a Union range to collect first cell of the rows having data and increase their height at once, at the code end:
Sub RowHeightForNotEmptyRowsInUsedRange()
Dim sh As Worksheet, lastR As Long, rngUR As Range, rngH As Range, i As Long
Set sh = ActiveSheet
Set rngUR = sh.UsedRange
For i = 1 To rngUR.rows.count
If WorksheetFunction.CountA(rngUR.rows(i)) > 0 Then
addToRange rngH, rngUR.cells(i, 1)
End If
Next i
If Not rngH Is Nothing Then rngH.EntireRow.RowHeight = 18
End Sub
Private Sub addToRange(rngU As Range, rng As Range)
If rngU Is Nothing Then
Set rngU = rng
Else
Set rngU = Union(rngU, rng)
End If
End Sub
In this sheet, I am trying to search in a range for empty cells, and deleting their respective rows.
Sub Delete()
'Amass row numbers
Dim B, Blank As Range
Dim Deletion() As Long
Dim D As Long
Set Blank = Sheets("Quotation").Range("I17:I3816")
D = 0
For Each B In Blank
If IsEmpty(B) Then
D = D + 1
ReDim Preserve Deletion(D)
Deletion(D) = B.Row
End If
Next B
Dim Amass As Range
'A starting point for the Amass range - should it need one pre-Union?
Set Amass = Sheets("Quotation").Range("10000:10000")
'Amass rows
For i = 1 To D
Set Amass = Union(Amass, Sheets("Quotation").Range(Deletion(i) & ":" & Deletion(i)))
Next i
'Delete rows
Amass.EntireRow.Delete
End Sub
It fails on the last action, with the error:
"Delete method of the range class failed"
Am I using the array and "ReDim Preserve" correctly?
I think something like this is what you're looking for:
Sub tgr()
Dim ws As Worksheet
Dim rCheck As Range
Dim rDel As Range
Set ws = ActiveWorkbook.Sheets("Quotation")
For Each rCheck In ws.Range("I17", ws.Cells(ws.Rows.Count, "I").End(xlUp)).Cells
If IsEmpty(rCheck) Then
If Not rDel Is Nothing Then Set rDel = Union(rDel, rCheck) Else Set rDel = rCheck
End If
Next rCheck
If Not rDel Is Nothing Then rDel.EntireRow.Delete
End Sub
I'm having some trouble with a macro I've been working on. It's used to delete blanks (over a million blank rows) when another separate macro is run. If I get this one working, I would like to merge the two macros together.
Here is the macro:
Sub Test()
DeleteBlankTableRows ActiveSheet.ListObjects(1)
End Sub
Sub DeleteBlankTableRows(ByVal tbl As ListObject)
Dim rng As Range
Set rng = tbl.DataBodyRange ' Get table data rows range.
Dim DirArray As Variant
DirArray = rng.Value2 ' Save table values to array.
' LOOP THROUGH ARRAY OF TABLE VALUES
Dim rowTMP As Long
Dim colTMP As Long
Dim combinedTMP As String
Dim rangeToDelete As Range
' Loop through rows.
For rowTMP = LBound(DirArray) To UBound(DirArray)
combinedTMP = vbNullString ' Clear temp variable.
' Loop through each cell in the row and get all values combined.
For colTMP = 1 To tbl.DataBodyRange.Columns.Count
combinedTMP = combinedTMP & DirArray(rowTMP, colTMP)
Next colTMP
' Check if row is blank.
If combinedTMP = vbNullString Then
' Row is blank. Add this blank row to the range-to-delete.
If rangeToDelete Is Nothing Then
Set rangeToDelete = tbl.ListRows(rowTMP).Range
Else
Set rangeToDelete = Union(rangeToDelete, tbl.ListRows(rowTMP).Range)
End If
End If
Next rowTMP
' DELETE BLANK TABLE ROWS (if any)
If Not rangeToDelete Is Nothing Then rangeToDelete.Delete
End Sub
First time it is run, it loads and acts like it's going to work. Less than a minute after loading...nothing happens (at least, visually). I run it again and it loads quickly; this time, the blank rows are visually gone.
A similar idea using an explicit parent sheet reference and Index and Max to determine if a row is blank.
Option Explicit
Public Sub DeleteRowsIfBlank()
Dim ws As Worksheet, table As ListObject, arr(), i As Long, counter As Long, unionRng As Range
Set ws = ThisWorkbook.Worksheets("Sheet1")
Set table = ws.ListObjects(1)
arr = table.DataBodyRange.Value
counter = table.DataBodyRange.Cells(1, 1).Row
For i = LBound(arr, 1) To UBound(arr, 1)
If Application.Max(Application.Index(arr, i, 0)) = 0 Then
If Not unionRng Is Nothing Then
Set unionRng = Union(unionRng, table.Range.Rows(counter))
Else
Set unionRng = table.Range.Rows(counter)
End If
End If
counter = counter + 1
Next
If Not unionRng Is Nothing Then unionRng.Delete
End Sub
I am trying to delete duplicate values in a temporary list based on a value in a combobox. The code below loops through individual rows to check whether a value matches. It is slow.
Dim ws As Worksheet
Dim i As Long
Set ws = Sheets("TempList3")
On Error Resume Next
For i = Cells(Rows.Count, 2).End(xlUp).Row To 1 Step -1
If Cells(i, 2) <> Sheets("Sheet1").ComboBox2.Value Then
ws.Rows(i).EntireRow.Delete
End If
Next
Is there a way to evaluate the entire column's values against the combobox's value once and then delete all rows on a worksheet. Or perhaps there is a better way?
I used a looping Find function, it deletes the row where the value was found and then it searches again and deletes the next row it finds until it can no longer find the Combo value on the sheet:
Sub find_cell()
Dim find_cell As Range
Set ws = Sheets("TempList3")
stop_loop = False
Do Until stop_loop = True
Set find_cell = ws.Cells.Find(What:=Sheets("Sheet1").ComboBox2.Value, LookAt:=xlWhole)
If Not find_cell Is Nothing Then
ws.Rows(find_cell.Row).EntireRow.Delete
Else
stop_loop = True
End If
Loop
End Sub
Not knowing how many rows you are talking about, I used 10 thousand for my example codes. here are two examples, try the both and see what works best for you.
You can run through the column and unionize the range found, then delete the rows, for example.
See here for example workbook
Sub UnIonRng()
Dim FrstRng As Range
Dim UnIonRng As Range
Dim c As Range, s As String
s = Sheets("Sheet1").ComboBox2
Set FrstRng = Range("B:B").SpecialCells(xlCellTypeConstants, 23)
For Each c In FrstRng.Cells
If c = s Then
If Not UnIonRng Is Nothing Then
Set UnIonRng = Union(UnIonRng, c) 'adds to the range
'MsgBox UnionRng.Address 'remove later
Else
Set UnIonRng = c
End If
End If
Next c
UnIonRng.EntireRow.Delete
End Sub
Or you can try to filter the column B and delete the rows that way:
Sub FilterDeleteRow()
Dim ws As Worksheet
Dim LstRw As Long, Rng As Range, s As String, x
Set ws = Sheets("TempList3")
s = Sheets("Sheet1").ComboBox2
Application.ScreenUpdating = 0
With ws
LstRw = .Cells(.Rows.Count, "B").End(xlUp).Row
x = Application.WorksheetFunction.CountIf(.Range("B:B"), s)
If x > 0 Then
Columns("B:B").AutoFilter Field:=1, Criteria1:=s
Set Rng = .Range("B2:B" & LstRw).SpecialCells(xlCellTypeVisible)
Rng.EntireRow.Delete
.AutoFilterMode = 0
Else: MsgBox "Not Found"
End If
End With
End Sub
Have a range of cell with column headings as weeks In the range of cells I want to look for a number, say
1 if it finds a 1 then look at a column in said row for a variable, 2 or 4 whatever Now I want to put a triangle (can be copy and paste a cell) in the cell that has the "1" in it then skip over the number of week variable and add another triangle and keep doing this until the end of the range. Then skip down to the next row and do the same, until the end of the range.
Then change to the next page and do the same thing... through the whole workbook.
I think I have it done, don't know if it's the best way.
I get a error 91 at the end of the second loop, the first time the second loop ends it goes through the error code.
The second time the second loop ends it errors.
I don't understand it runs through once, but not twice.
Sub Add_Triangles2()
Dim Rng As Range
Dim OffNumber As Integer
Dim SetRange As Range
Dim OffsetRange As Range
Dim ws As Worksheet
Set SetRange = Sheets("Sheet1").Range("G25") ' Used to stop the second loop in range
Worksheets(1).Activate
Worksheets(1).Range("A1").Select ' Has item to be pasted (a triangle)
Selection.Copy
For Each ws In Worksheets
Worksheets(ws.Name).Activate
With Range("C4:G25")
Set Rng = .Find(1, LookIn:=xlValues)
If Not Rng Is Nothing Then
FirstAddress = Rng.Address
Do
Rng.Activate
ActiveSheet.Paste
Do
OffNumber = Range("A" & ActiveCell.Row)
Set OffsetRange = SetRange.Offset(0, -OffNumber)
If Not ActiveCell.Address < OffsetRange.Address Then
Exit Do
Else
End If
ActiveCell.Offset(, OffNumber).Select
ActiveSheet.Paste
Loop While (ActiveCell.Address <= OffsetRange.Address)
On Error GoTo ErrorLine
Set Rng = .FindNext(Rng)
Loop While Not Rng Is Nothing And Rng.Address <> FirstAddress
End If
End With
ErrorLine:
On Error GoTo 0
Application.EnableEvents = True
Next ws
Application.CutCopyMode = False
End Sub
I was not able to get an Error 91 using the data set I built from your explanation, maybe a screenshot of the layout could help recreate the issue.
However, I would do something like this, it will look at the value of each cell in the range C4:G25, and if it equals 1, it will paste the symbol stored in Cell A1.
Sub Add_Triangles2()
Dim Rng As Range
Dim rngSymbol As Range
Dim intFindNum As Integer
Dim ws As Worksheet
Set rngSymbol = Range("A1") 'Set range variable to hold address of symbol to be pasted
intFindNum = 1 'Used to hold number to find
Worksheets(1).Activate
For Each ws In Worksheets
Worksheets(ws.Name).Activate
For Each Rng In Range("C4:G25")
If Rng.Value = intFindNum Then
rngSymbol.Copy Rng
End If
Next Rng
Next ws
End Sub
I got it....
Sub Add_TriWorking()
Dim Rng As Range
Dim rngSymbol As Range
Dim intFindNum As Integer
Dim ws As Worksheet
Dim OffNumber As Integer
Dim SetRange As Range
Dim OffsetRange As Range
Set SetRange = Sheets("Sheet1").Range("G25") ' Used to stop the second loop in range
Set rngSymbol = Range("A1") 'Set range variable to hold address of symbol to be pasted
intFindNum = 1 'Used to hold number to find
Worksheets(1).Activate
For Each ws In Worksheets
Worksheets(ws.Name).Activate
For Each Rng In Range("C4:G25")
If Rng.Value = intFindNum Then
rngSymbol.Copy Rng
Rng.Activate
ActiveCell.Copy
Do
OffNumber = Range("A" & ActiveCell.Row)
Set OffsetRange = SetRange.Offset(0, -OffNumber)
If Not ActiveCell.Address < OffsetRange.Address Then
Exit Do
Else
End If
ActiveCell.Offset(, OffNumber).Select
ActiveSheet.Paste
Loop While (ActiveCell.Address <= OffsetRange.Address)
On Error GoTo ErrorLine
End If
Next Rng
ErrorLine:
On Error GoTo 0
Application.EnableEvents = True
Next ws
Application.CutCopyMode = False
End Sub