I have the following problem:
I search a value and want to delete the cell. But I need to delete the whole dataset (from Column A to E). E.g. I find a value in Cell B4 and want to delete the dataset A4 - E4. I don't want to delete the EntireRow because I have more data in the datasheet.
My Code:
Sub DeleteCells2()
Dim rng As Range
Dim i As Integer, counter As Integer, ib As String
ib = InputBox("Geben Sie bitte die PLZ und den Ort ein")
'Set the range to evaluate to rng.
Set rng = Range("C2:C99")
'initialize i to 1
i = 1
'Loop for a count of 1 to the number of rows
'in the range that you want to evaluate.
For counter = 1 To rng.Rows.Count
'If cell i in the range contains an "x",
'delete the row.
'Else increment i
If rng.Cells(i) = ib Then
rng.Cells(i).EntireRow.Delete
Else
i = i + 1
End If
Next
End Sub
Delete Data Rows
Sub DeleteLocation()
Dim Location As String
Location = InputBox("Geben Sie bitte die PLZ und den Ort ein")
If Len(Location) = 0 Then
MsgBox "No location entered.", vbExclamation
Exit Sub
End If
Dim ws As Worksheet: Set ws = ActiveSheet ' improve!
Dim rg As Range: Set rg = ws.Range("A1").CurrentRegion
Dim crg As Range: Set crg = rg.Columns(3)
Dim r As Long
For r = crg.Rows.Count To 2 Step -1
If StrComp(CStr(crg.Cells(r).Value), Location, vbTextCompare) = 0 Then
rg.Rows(r).Delete xlShiftUp
'Else ' not a match; do nothing
End If
Next r
MsgBox Location & " deleted.", vbInformation
End Sub
Related
Is there in VBA faster way to change row (or cell) color based on values without referring to cell
Referring to cell each time inside loop is very slow, that's why i am looking for faster method doing it in VBA.
Table:
Amount1
Amount2
100
50
20
200
...
...
If Amount1 is greater than Amount2, entire row(or cell) is red, vice versa entire row(or cell) is green.
Thank You!
It would have been helpful if you had clarified why you can't use CF as suggested, but if you really can't when looping it's best to refer to directly to cells as little as possible, especially changing values or formats. Try something like this:
Sub SampleValues()
Dim bGreater As Boolean
Dim rng As Range, rRow As Range
Set rng = ActiveSheet.Range("A1:B1000")
rng.Formula = "=RANDBETWEEN(1,1000)"
rng.Value = rng.Value
End Sub
Sub RedOrGreen()
Dim clr As Long, i as long
Dim rng As Range, rRow As Range
Dim arr As Variant
Const clrMore = vbGreen, clrLessEqual = vbRed
Dim t As Single
t = Timer
Set rng = Range("A1:B1000")
arr = rng.Value
For Each rRow In rng.Rows
i = i + 1
If arr(i, 2) > arr(i, 1) Then
clr = clrMore
Else
clr = clrLessEqual
End If
If rRow.Interior.Color <> clr Then
rRow.Interior.Color = clr
End If
Next
Debug.Print Timer - t
End Sub
Highlight Rows
Sub HighlightRows()
Dim t As Double: t = Timer
' Define constants (adjust).
Const PROC_TITLE As String = "Highlight Rows"
Const SMALL_COL As Long = 1
Const GREAT_COL As Long = 2
Dim RowColors(): RowColors = VBA.Array(vbGreen, vbRed)
' Reference the table range.
' Turn off screen updating.
Application.ScreenUpdating = False
Dim ws As Worksheet: Set ws = ActiveSheet ' improve!
If ws.AutoFilterMode Then ws.AutoFilterMode = False
Dim trg As Range: Set trg = ws.Range("A1").CurrentRegion
' Validate rows and columns.
' Validate rows.
Dim rCount As Long: rCount = trg.Rows.Count
If rCount < 2 Then
MsgBox "No data or just headers in the range '" _
& trg.Address(0, 0) & "'.", vbCritical, PROC_TITLE
Exit Sub ' screen updating will automatically get turned on
End If
' Validate columns.
Dim cCount As Long: cCount = trg.Columns.Count
Dim MaxCol As Long: MaxCol = Application.Max(SMALL_COL, GREAT_COL)
If cCount < GREAT_COL Then
MsgBox "Column " & MaxCol & " is greater than the number " _
& "of columns (" & cCount & ") in the range ('" _
& trg.Address(0, 0) & "').", vbCritical, PROC_TITLE
Exit Sub ' screen updating will automatically get turned on
End If
' Reference and populate the helper columns.
' Insert two helper columns adjacent to the right of the table range.
trg.Offset(, cCount).Resize(, 2).Insert xlShiftToRight
' Remove this line if there is no data to the right.
' Reference the expanded table range (including the helper columns)...
Dim erg As Range: Set erg = trg.Resize(, cCount + 2) ' has headers
' ... and reference its data to be used with 'SpecialCells'.
Dim edrg As Range: Set edrg = erg.Resize(rCount - 1).Offset(1) ' no headers
' Reference the helper columns.
Dim CompareCol As Long: CompareCol = cCount + 1 ' for the auto filter
Dim crg As Range: Set crg = erg.Columns(CompareCol)
Dim irg As Range: Set irg = erg.Columns(cCount + 2)
' Write an ascending integer sequence to the Integer column.
irg.Value = ws.Evaluate("ROW(1:" & rCount & ")")
' Write the values from the criteria columns to arrays.
Dim SmallData(): SmallData = erg.Columns(SMALL_COL).Value
Dim GreatData(): GreatData = erg.Columns(GREAT_COL).Value
' Define the Compare array.
Dim CompareData(): ReDim CompareData(1 To rCount, 1 To 1)
Dim SmallVal, GreatVal, r As Long
' Write the Compare results to the Compare array
' (1 for the 1st color and 2 for the 2nd), ...
For r = 2 To rCount ' skip headers
SmallVal = SmallData(r, 1)
GreatVal = GreatData(r, 1)
If IsNumeric(SmallVal) And IsNumeric(GreatVal) Then
Select Case SmallVal
Case Is < GreatVal: CompareData(r, 1) = 1
Case Is > GreatVal: CompareData(r, 1) = 2
End Select
End If
Next r
Erase SmallData
Erase GreatData
' ... write the results from the array to the Compare column...
crg.Value = CompareData
Erase CompareData
' ... and sort the range by it.
erg.Sort crg, xlAscending, , , , , , xlYes
' Highlight the rows.
edrg.Interior.Color = xlNone ' clear previous colors
Dim vedrg As Range
For r = 1 To 2
erg.AutoFilter CompareCol, CStr(r)
On Error Resume Next ' prevent error when no filtered rows
Set vedrg = edrg.SpecialCells(xlCellTypeVisible)
On Error GoTo 0
ws.AutoFilterMode = False ' turn off the auto filter!!!
If Not vedrg Is Nothing Then
Debug.Print vedrg.Address ' only two areas are being highlighted
vedrg.Interior.Color = RowColors(r - 1) ' 'RowColors' is zero-based
Set vedrg = Nothing ' reset for the next iteration
End If
Next r
' Clean up.
' Sort the range by the Integer column restoring initial order.
erg.Sort irg, xlAscending, , , , , , xlYes
' Delete the helper columns.
crg.Resize(, 2).Delete xlShiftToLeft
' If you have removed the Insert-line, replace this line with:
'crg.Resize(, 2).Clear
' Turn on screen updating to immediately see the changes
' (if the worksheet is active) before OK-ing the message box.
Application.ScreenUpdating = True
Debug.Print Format(Timer - t, "00.000000")
' Inform.
MsgBox "Rows highlighted.", vbInformation, PROC_TITLE
End Sub
Given a range of values in column B, for example - we only have 2 values from B4 to B5, where 12 is in B4 and 99 is in B5.
For each value(we call it product code) in column B (here they are 12 and 99), I want to:
create a duplicate of the existing sheet "Order", and replace the cell which is named "Symbol"(C2) with the product code (the value in the collection)
name the new sheet with the value (product code) in the cell
Trick: The number of values is dynamic, where it definitely starts with B4, but might end with any value in column B
For the code, I am thinking the logic should be:
##(1) get the range of values in column B starting from B4 (which is dynamic)
##(2) loop through all values in the column, create a sheet for each and change its name to the product
However, I am not sure
(1) how to get the values within a column and maybe store them in a collection to facilitate 2nd step?
(2) maybe I can do something like below for the 2nd step:
Dim SourceSheet As Object
Set SourceSheet = ActiveSheet
SourceSheet.Copy After:=SourceSheet
Dim NewSheet As Object
Set NewSheet = ThisWorkbook.Sheets(SourceSheet.Index + 1)
On Error GoTo ERR_RENAME
NewSheet.Name = "InputName"
On Error GoTo 0
But here we need to do it for each item in the collection we have generated in step 1, and name it according to the item value (product code in the collection).
Any help would be greatly appreciated, thanks in advance.
Add Worksheets
Option Explicit
Sub CreateOrders()
' Define constants.
Const PROC_TITLE As String = "Create Orders"
Const DATA_SHEET_NAME As String = "Sheet1" ' adjust!
Const DATA_FIRST_CELL As String = "B4"
Const SOURCE_SHEET_NAME As String = "Order"
Const DST_CELL As String = "C2"
' Reference the workbook.
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
' Reference the data range.
Dim ws As Worksheet: Set ws = wb.Sheets(DATA_SHEET_NAME)
If ws.AutoFilterMode Then ws.AutoFilterMode = False
Dim rg As Range, rCount As Long
With ws.Range(DATA_FIRST_CELL)
Dim lCell As Range: Set lCell = .Resize(ws.Rows.Count - .Row + 1) _
.Find("*", , xlFormulas, , , xlPrevious)
If lCell Is Nothing Then
MsgBox "No product IDs found.", vbExclamation, PROC_TITLE
Exit Sub
End If
rCount = lCell.Row - .Row + 1
Set rg = .Resize(rCount)
End With
' Write the values from the data range to an array.
Dim Data() As Variant
If rCount = 1 Then
ReDim Data(1 To 1, 1 To 1): Data(1, 1) = rg.Value
Else
Data = rg.Value
End If
' Write the unique values from the array to a dictionary.
Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
dict.CompareMode = vbTextCompare
Dim r As Long, rString As String
For r = 1 To rCount
rString = CStr(Data(r, 1))
If Len(rString) > 0 Then ' not blank
dict(rString) = Empty
End If
Next r
If dict.Count = 0 Then
MsgBox "The product ID column is blank.", vbExclamation, PROC_TITLE
Exit Sub
End If
' Reference the source worksheet.
Dim sws As Worksheet: Set sws = wb.Sheets(SOURCE_SHEET_NAME)
' Create orders.
Application.ScreenUpdating = False
Dim dsh As Object, rKey As Variant, oCount As Long, ErrNum As Long
For Each rKey In dict.Keys
' Check if the order exists.
On Error Resume Next ' defer error trapping
Set dsh = wb.Sheets(rKey)
On Error GoTo 0 ' turn off error trapping
' Create order.
If dsh Is Nothing Then ' the order doesn't exist
sws.Copy After:=wb.Sheets(wb.Sheets.Count) ' copy as last sheet
Set dsh = wb.Sheets(wb.Sheets.Count) ' reference the new last sheet
On Error Resume Next ' defer error trapping
dsh.Name = rKey ' rename
ErrNum = Err.Number
On Error GoTo 0 ' turn off error trapping
If ErrNum = 0 Then ' valid sheet name
dsh.Range(DST_CELL).Value = rKey ' write to the cell
oCount = oCount + 1
Else ' invalid sheet name
Application.DisplayAlerts = False ' delete without confirmation
dsh.Delete
Application.DisplayAlerts = True
End If
'Else ' the order exists; do nothing
End If
Set dsh = Nothing ' reset for the next iteration
Next rKey
Application.ScreenUpdating = True
' Inform.
Select Case oCount
Case 0: MsgBox "No new orders.", vbExclamation, PROC_TITLE
Case 1: MsgBox "One new order created.", vbInformation, PROC_TITLE
Case Else: MsgBox oCount & " new orders created.", _
vbInformation, PROC_TITLE
End Select
End Sub
I have managed to insert rows based on cell value for instance if A1 cell is 20, I run the macro, 20 rows appear under A1, those rows are blank right, I need the 20 new cells below A1 to be number 1 to 20 ( the number in A1) let me know if possible.
Cheers Adrien
Try this:
Sub counter()
Dim i as integer
for i = 2 to cells(1, 1) + 1
cells(i, 1) = i - 1
next i
End Sub
Insert an Integer Sequence Below a Cell
A Basic Example For the Active Sheet
Note that this doesn't insert rows, it just writes the integer sequence to the cells below A1.
Sub IntegersBelow()
With Range("A1")
.Resize(.Value).Offset(1).Value _
= .Worksheet.Evaluate("ROW(1:" & CStr(.Value) & ")")
End With
End Sub
Applied to Your Actual Use Case
Adjust the values in the constants section.
Sub InsertIntegersBelow()
' Use constants to change their values in one place instead
' of searching for them in the code (each may be used multiple times).
Const wsName As String = "Sheet1"
Const fRow As Long = 3
Const Col As String = "E"
' Reference the workbook ('wb').
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing the code
' Reference the worksheet ('ws').
Dim ws As Worksheet: Set ws = wb.Worksheets(wsName)
' Calculate the last row ('lRow'),
' the row of the last non-empty cell in the column.
Dim lRow As Long: lRow = ws.Cells(ws.Rows.Count, Col).End(xlUp).Row
' Validate the last row.
If lRow < fRow Then
MsgBox "No data in column range.", vbInformation
Exit Sub
End If
Dim cCell As Range ' Current Cell
Dim cValue As Variant ' Current Cell Value
Dim r As Long ' Current Row
For r = lRow To fRow Step -1 ' loop backwards
Set cCell = ws.Cells(r, Col) ' reference the current cell...
cValue = cCell.Value ' ... and write its value to a variable
If VarType(cValue) = vbDouble Then ' is a number
cValue = CLng(cValue) ' ensure whole number
If cValue > 0 Then ' greater than 0
' Insert the rows.
cCell.Offset(1).Resize(cValue) _
.EntireRow.Insert xlShiftDown, xlFormatFromLeftOrAbove
With cCell.Offset(1).Resize(cValue)
' Write the values.
.Value = ws.Evaluate("ROW(1:" & cValue & ")")
' Apply formatting.
.ClearFormats
.Font.Bold = True
End With
'Else ' less than or equal to zero; do nothing
End If
'Else ' is not a number
End If
Next r
MsgBox "Rows inserted.", vbInformation
End Sub
I am trying to pick a random value from a range of values and output this value in Cell E6.
Some of the cells are blank so I need to pick from a cell that contains a value.
The range of which the values to choose from is H127:1127.
Sub Generate()
Dim i As Double
Dim ws As Worksheet
Set ws = Sheets("Upstream-Overall")
For Each Cell In ws.Range("H127:H1127")
If ActiveCell.Value <> "" Then
Range("E6") = Random_Number = Application.WorksheetFunction.RandBetween(0.1, 5)
End If
Next Cell
End Sub
Return the Number From a Random Cell
Sub Generate()
Const wsName As String = "Upstream-Overall"
Const sRangeAddress As String = "H127:H1127"
Const dCellAddress As String = "E6"
' Reference the worksheet in the workbook containing this code.
Dim ws As Worksheet: Set ws = ThisWorkbook.Worksheets(wsName)
' Write the values from the first column of the range to an array.
Dim Data As Variant: Data = ws.Range(sRangeAddress).Columns(1).Value
Dim sr As Long, dr As Long
' Shift the numeric values (up) to the beginning of the array.
For sr = 1 To UBound(Data, 1)
If VarType(Data(sr, 1)) = 5 Then ' is a number
dr = dr + 1
Data(dr, 1) = Data(sr, 1)
'Else ' is not a number; do nothing
End If
Next sr
' Check if at least one number was found.
If dr = 0 Then
MsgBox "No numbers in the first column of the range.", vbCritical
Exit Sub
End If
' Write the number from a random element
' of the numeric part of the array to the cell.
ws.Range(dCellAddress).Value = Data(Int(dr * Rnd + 1), 1)
' Inform of success.
MsgBox "New random number generated.", vbInformation
End Sub
You could do something like this:
Sub Generate()
Dim ws As Worksheet, rng As Range, i As Long, v
Set ws = Sheets("Upstream-Overall")
Set rng = ws.Range("H127:H1127")
Do
i = Application.RandBetween(1, rng.Cells.Count)
v = rng.Cells(i).Value
Loop While Len(v) = 0 'loop until selected cell has a value
ws.Range("E6").Value = v
End Sub
(assuming the range will never be completely empty)
The code i've provided here is able to search Sheet1 and then copy the value ( the whole row containing the value) that has been searched into a new sheet and then rename the sheet after search string.
But now i am trying to search all of the sheet in excel instead of one sheet, and this time i am also required to include the header of the relevant row.
for example if i search Apple, the macro will search all the sheet for Apple, and for example if apple is found on sheet7, it will be copied in a new sheet named "Apple" with the relevant header.
But example if there are both apple on sheet7 and sheet8, both will be copied into a new sheet name "Apple" but both of the header must also be copied into the new sheet.
How do i start working on it? i know i have to find out the number of sheets and loop it but after that what should i include?
Dim strSearch
Dim rg As Range, rgF As Range
Dim i As Integer
Dim celltxt As String
Dim strSearch2
'Dim x, NumberOfWorksheet As Integer 'to count worksheet for loop
Application.ScreenUpdating = False
strSearch = Application.InputBox("Please enter the search string")
strSearch2 = Replace(strSearch, "*", " ")
' NumberOfWorksheet = ThisWorkbook.Sheets.Count
' For x = 0 To NumberOfWorksheet
If Len(strSearch) > 0 Then
Worksheets.Add().Name = strSearch2
Set rg = Sheets("Sheet1").Cells(1).CurrentRegion 'Define whole search range here
For i = 1 To rg.Rows.Count 'we look rows by rows (to copy row once only)
Set rgF = rg.Rows(i).Find(strSearch, , xlValues, xlWhole)
If Not rgF Is Nothing Then
rg.Rows(i).Copy Sheets(strSearch2).Range("A60000").End(xlUp).Offset(1, 0)
Set rgF = Nothing
End If
Next i
'Next x
Application.ScreenUpdating = True
End If
It has worked on Excel 2007:
Sub sof20312498SearchCopy()
Dim i As Long, nRowsAddePerSheet As Long, nRows As Long, _
nRowsMax As Long, nSheets As Long
Dim strSearch, strSearch2
Dim rg As Range, rgF As Range
Dim wks
'
'Dim x, NumberOfWorksheet As Integer 'to count worksheet for loop
Dim x
'
strSearch = Application.InputBox("Please enter the search string")
strSearch2 = Replace(strSearch, "*", "")
If Len(strSearch2) <= 0 Then
MsgBox "Abandon: Search string must not be empty."
Exit Sub
End If
Application.ScreenUpdating = False
nSheets = Sheets.Count
nRowsMax = ActiveSheet.Rows.Count
For x = 1 To nSheets
'
' get the worksheet, if nonexistent, add it:
'
On Error Resume Next
Set wks = Worksheets(strSearch2)
If (Err) Then
Set wks = Worksheets.Add(After:=Sheets(Sheets.Count))
wks.Name = strSearch2
Err.Clear
End If
On Error GoTo 0
'
' Define whole search range here:
'
'Set rg = Sheets("Sheet1").Cells(1).CurrentRegion
'
Sheets(x).Activate
Set rg = ActiveSheet.Cells(1).CurrentRegion
'
' we look rows by rows (to copy row once only):
'
nRows = rg.Rows.Count
nRowsAddePerSheet = 0
For i = 1 To nRows
Set rgF = rg.Rows(i).Find(strSearch, , xlValues, xlWhole)
'
' if found, copy the source row as the last row of the destination Sheet:
'
If Not rgF Is Nothing Then
'
' copy header if required, Row(1) is assumed as header:
'
If (nRowsAddePerSheet <= 0) Then
If (i <> 1) Then
rg.Rows(1).Copy wks.Range("A" & nRowsMax).End(xlUp).Offset(1, 0)
End If
End If
'
rg.Rows(i).Copy wks.Range("A" & nRowsMax).End(xlUp).Offset(1, 0)
nRowsAddePerSheet = nRowsAddePerSheet + 1
End If
Next
Next
Set rgF = Nothing
Set rg = Nothing
Set wks = Nothing
Application.ScreenUpdating = True
End Sub
For the search string "Apple", Sheet1 and Sheet2 contain it as whole word:
Sheet1
Sheet2
Apple - Here is the Sheet Apple: