I have the following VBA Function where it will find the info typed into the Input Box and deletes every row with that value.
How can I change it to delete all rows except for the value you enter. Example I enter 123. I want it to delete all rows except for the cells in column B with 123.
Sub DeleteRows()
Dim c As Range
Dim SrchRng As Range
Dim SrchStr As String
Set SrchRng = ActiveSheet.Range("B1", ActiveSheet.Range("B4343").End(xlUp))
SrchStr = InputBox("Please Enter Value")
Do
Set c = SrchRng.Find(SrchStr, LookIn:=xlValues)
If Not c Is Nothing Then c.EntireRow.Delete
Loop While Not c Is Nothing
End Sub
OK there may well be a better way to do this but I went with creating a temp sheet, copy in the rows that match your search, clear all rows in the sheet and finally copy back the rows that matched then delete the temp sheet:
Sub DeleteRows()
Dim c As Range, b As Range, SrchRng As Range, SrchStr As String, MasterSheet As Worksheet, TempSheet As Worksheet
Set MasterSheet = ActiveSheet
Set SrchRng = ActiveSheet.Range("A1", ActiveSheet.Range("A4343").End(xlUp))
SrchStr = InputBox("Please Enter Value")
Worksheets.Add
Set TempSheet = ActiveSheet
MasterSheet.Select
Set c = SrchRng.Find(SrchStr, LookIn:=xlValues)
Set b = c
Do
If Not c Is Nothing Then
c.EntireRow.Copy
TempSheet.Range("A" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial xlPasteAll
End If
Set c = SrchRng.FindNext(After:=c)
If c.Address = b.Address Then Exit Do
Loop While Not c Is Nothing
Range("A2:A" & Rows.Count).EntireRow.ClearContents
TempSheet.Range("A2:A" & TempSheet.Range("A" & Rows.Count).End(xlUp).Row).EntireRow.Copy
ActiveSheet.Range("A2:A" & TempSheet.Range("A" & Rows.Count).End(xlUp).Row).PasteSpecial xlPasteAll
Application.DisplayAlerts = False
TempSheet.Delete
Application.DisplayAlerts = True
End Sub
Hope that helps.
I started playing around trying to populate an array from the search results in one go without looping it but it didn't go well and I have run out of spare time to explore this further unfortunately. My idea was to try and populate an array from the results in one go, then select all rows minus anything in the joined array then delete. Not sure how possible that is but maybe explore it if you get time.
My Test data was using column A, you will need to change a few parts for column B.
Related
Suppose you have Excel data in the format
Row A
Row B
Row C
blank row
Row X
Row Y
Row Z
blank
I would like to 1) go to the row with the blank 2) copy the entire contents of the two rows above 3) paste the contents.
In the above example, the results would be
Row A
Row B
Row C
Row B
Row C
blank
Row X
Row Y
Row Z
Row Y
Row Z
blank
I am able to find the blanks. My code currently looks something like
Sub Find_Copy()
Dim rCell As Range
Dim r As Range
Dim r2 As Range
'We call the function and tell it to start the search in cell B1.
Set rCell = FindNextEmpty(Range("B8")) 'this is a separate function
'Shows a message box with the cell address. Right here is where
'you write the code that uses the empty cell.
rCell.Value = "Filled by macro 999"
MsgBox rCell.Address & " " & rCell.Value
rCell.Offset(-2, 0).EntireRow.Select 'dmt, select the row one above the blanks
Selection.Copy
Selection.Insert Shift:=xlDown
Set rCell = Nothing
End Sub
Can anyone help me get this sorted out? Thank you!
The sub which does the work is enhanceList. It takes as parameter the range you want to work on.
The basic idea of my macro is to work from the bottom up while inserting the rows.
Option Explicit
Public Sub test_enhanceList()
Dim rg As Range
Set rg = table1.Range("A1:A8") '<<< adjust to your needs
enhanceList rg
End Sub
' The sub which does the work
Private Sub enhanceList(rgToEnhance As Range)
Dim c As Range
With rgToEnhance
'we will start at the end of the range
Set c = .Cells(.Rows.Count)
End With
Dim i As Long
Do
If LenB(c.Value2) = 0 Then 'test for empty cell
For i = 1 To 2
'insert empty row and take value from 3rd row above
c.EntireRow.Insert xlShiftDown
'c.offset(-1) = new cell
'c.offset(-3) = value to copy
c.Offset(-3).EntireRow.Copy c.Offset(-1)
Next
End If
Set c = c.Offset(-1) 'set c to the cell above
Loop Until c.Row = rgToEnhance.Cells(1, 1).Row 'stop when first cell is reached
End Sub
Add this after your insert and you can get both rows B and C right. You'll have to add a loop with a range limit starting before your function call to get the next empty cell to add Y and Z and anything else that might come after. Post your function code and I can probably write a loop that will do it later.
rCell.Offset(-1, 0).EntireRow.Select 'dmt, select the row one above the blanks
Selection.Copy
rCell.Offset(-2, 0).EntireRow.Select 'dmt, select the row one above the blanks
Selection.Insert Shift:=xlDown
To choose the column you'd like to do this on by clicking on it change this line:
Set rCell = FindNextEmpty(ActiveCell.Offset(0, 0))
To this:
Set rCell = FindNextEmpty(Selection)
Then before running the macro, choose cell B1
Rather than changing my answer, I added a new one. Added a couple lines to find the range of the data, and then looped through each cell in the range, testing for empty. It eliminates the need for the extra function.
Try this:
Sub Dan_Find_Copy()
Dim wkb As Workbook
Dim rCell As Range
Dim r As Range
Dim r2 As Range
Dim colNumber As Integer 'to store the column index
Dim rowNumber As Long 'to store the last row containing data
Dim i As Long 'iterator
'Need to get the range of the data
Set wkb = ActiveWorkbook
'store the column number of the selection
colNumber = Columns(Selection.Column).Column
'find the last row containing data
rowNumber = Cells(Rows.Count, colNumber).End(xlUp).Row
Set r = wkb.ActiveSheet.Range(Sheet1.Cells(1, colNumber), Sheet1.Cells(rowNumber, colNumber))
For Each rCell In r.Cells
If rCell.Value = "" Then
If MsgBox("Continue?", vbOKCancel, "Hello!") = vbOK Then
'Shows a message box with the cell address. Right here is where
'you write the code that uses the empty cell.
rCell.Value = "Filled by macro 999"
MsgBox rCell.Address & " " & rCell.Value
rCell.Offset(-2, 0).EntireRow.Select 'dmt, select the row one above the blanks
Selection.Copy
Selection.Insert Shift:=xlDown
rCell.Offset(-1, 0).EntireRow.Select 'dmt, select the row one above the blanks
Selection.Copy
rCell.Offset(-2, 0).EntireRow.Select 'dmt, select the row one above the blanks
Selection.Insert Shift:=xlDown
rCell.Select
Else
MsgBox ("You cancelled the process.")
Exit For
End If
End If
Next rCell
Set rCell = Nothing
Set r = Nothing
Set wkb = Nothing
End Sub
sI'm making a spreadsheet to update Project data for my company. I have code to identify what rows the new data should be inserted on, but am having trouble writing the command to properly paste the new data on the index. My code is:
Set wsDest = Worksheets("Projected Hours")
Dim uniqueid As String
Dim rng As Range, c As Range, myRng As Range
'Set range with values to be searched for matches
Set rng = wsDest.Range("projid")
'Fill string variable with string of text to be matched
uniqueid = Range("projectid")
'Loop through each cell in range
For Each c In rng
'Check if cell value matches the string to be matched
If c.Value = uniqueid Then
'Check if this is the first match (new range hasn't been filled yet)
If myRng Is Nothing Then
'Fill new range with cell
Set myRng = c
Else
'Join new matching cell together with previously found matches
Set myRng = Application.Union(myRng, c)
End If
End If
Next c
'Select entire row of each cell in new range
destrows = myRng.Rows
For Each Row In destrows
Range("newprincipal").Copy
wsDest.Range("D" & destrows()).PasteSpecial Paste:=xlPasteValues
Range("newinfo").Copy
wsDest.Range("F" & destrows()).PasteSpecial Paste:=xlPasteValues
Next Row
End Sub
Which gives the error "Subscript out of Range" on the first paste line. Am I indexing wrong? What should I change to paste the new information in these specific columns (D and F) in each row of the index? I need the last part to take each value in destrows, which should be a row number and paste my selections into D+(Row Number) and F+(Row Number).
I figured it out. Instead of defining my target rows first, I edited my code to paste in my info as it found the correct rows.
Sub UpdateProject()
Set wsDest = Worksheets("Projected Hours")
Dim uniqueid As String
Dim rng As Range, c As Range
'Set range with values to be searched for matches
Set rng = wsDest.Range("projid")
'Fill string variable with string of text to be matched
uniqueid = Range("projectid")
For Each c In rng
If c.Value = uniqueid Then
Range("newprincipal").Copy
wsDest.Range("D" & c.Row).PasteSpecial Paste:=xlPasteValues
Range("newinfo").Copy
wsDest.Range("F" & c.Row).PasteSpecial Paste:=xlPasteValues
End If
Next c
End Sub
Objective:
There is data stored in sheet "Risk Partner Data" in a table called "RPdata". In the table there is a column called "AICOW" which bears two results, yes or no.
In a second sheet called "Calc Data", I would like to build a macro that starts at after the last filled cell (but ignores a cell that is empty in between data), and for every row that has a "yes" result in AICOW, it copies into row A the corresponding [RPdata#Parish].
The result I am after is that at the end of Column A, the macro will add the parish name for only the parishes with AICOW (yes) and not any others.
I have attempted but my code is not working and I'm not sure its even right
Set Source = Sheet("Risk Partner Data")
Set c.FormulaR1C1 = _
"=if("RPdata[#[AICOW]]"=""Yes"","Yes",0)
Set Target = [RPdata#Parish]
Range("A1").End(xlDown).Offset(1, 0).Select
Selection.For each c in source.range(RPdata[#AICOW])
If c = "yes" Then
Source.Rows(c.Row).Copy Target.Rows(a)
a = a + 1
End If
End c
Instead of looping, consider filtering and copying the visible cells from the "Parish" column in one go.
Also, consider using the built-in ListObject and ListColumn objects.
Sub CopyParishes()
Dim riskPartnerDataTbl As ListObject
Dim parishCol As ListColumn, AICOWcol As ListColumn
Dim copyRng As Range
Set riskPartnerDataTbl = ThisWorkbook.Worksheets("Risk Partner Data").ListObjects("RPdata")
With riskPartnerDataTbl
Set parishCol = .ListColumns("Parish")
Set AICOWcol = .ListColumns("AICOW")
.Range.AutoFilter Field:=AICOWcol.Index, Criteria1:="Yes"
End With
On Error Resume Next
Set copyRng = parishCol.DataBodyRange.SpecialCells(xlCellTypeVisible)
On Error GoTo 0
If Not copyRng Is Nothing Then
copyRng.Copy
With ThisWorkbook.Worksheets("Calc Data")
.Cells(.Rows.Count, "A").End(xlUp).Offset(1).PasteSpecial xlPasteValues
End With
Application.CutCopyMode = False
End If
riskPartnerDataTbl.Range.AutoFilter Field:=AICOWcol.Index
End Sub
I have tried every possible method to search and find the solution to this problem but to no avail, My problem is to search a particular cell value in different sheets in a workbook and copy the entire row along with their headers (Every sheet has different header example, Lab1,Name, Date, Lab Test Type, LabType N, Name, Date, Test Type and so on) and loop through until last value is find with their respective headers. Any help in this regard will be highly appreciated and please forgive me for not knowing the right way to ask the question because i am totally a newbie to this forum.
This code below is giving me the results of the search cell, but because every search result has its own header which i am not getting at the result, as it only pasting the entire row of cell only through loop but not their headers.
Here are the example.
Sheet2 has Name Date Age Sex Cell No Test Type in Range A1:F1
Sheet3 has Name Date Age Sex Cell No Test Type2 Xray Range A1:G1
Sheet4 has Name Date Age Sex Cell No Test Type3 XRay ECG A1:H1
Option Explicit
Option Compare Text '< ignore case
Sub AllRecordSearchMacroForPhone()
Dim FirstAddress As String
Dim c As Range, Sheet As Worksheet
Dim rng As Range
Set rng = Range("D1")
If rng = Empty Then Exit Sub
For Each Sheet In Sheets
If Sheet.Name <> "Sheet1" Then
With Sheet.Columns(5)
Set c = .find(rng, LookIn:=xlValues, LookAt:=xlWhole)
If Not c Is Nothing Then
FirstAddress = c.Address
Do
c.EntireRow.Copy _
Destination:=Sheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Offset(1, 0)
Set c = .FindNext(c)
Loop Until c.Address = FirstAddress
End If
End With
End If
Next Sheet
Set c = Nothing
End Sub
Add marked line to your code:
If Not c Is Nothing Then
>>Sheet.Rows(1).Copy Destination:=Sheets("Sheet1").Range("A" & Sheets("Sheet1").Rows.Count).End(xlUp).Offset(1, 0)
FirstAddress = c.Address
I would like to ask whether it is possible to check inconsistent formula for a specific region.
In my case, col D and col E contain different sets of formula.
I just want to ensure that all formula in col E are consistent.
Is it possible to do so??
Here is one way.
Let's say your worksheet looks like this
Now Paste this code in a module and run it. It will tell you which cells have inconsistent formulas. See below screenshot
I have commented the code so that you will not have any problem understanding it. If you do simply ask :)
Option Explicit
Sub GetInConsCells()
Dim ws As Worksheet
Dim rng As Range, cl As Range, errCells As Range
Dim ErrorCells As String
Dim lRow As Long
'~~> Create a temp copy of the sheet
ThisWorkbook.Sheets("Sheet1").Copy After:=Sheets(ThisWorkbook.Sheets.Count)
Set ws = ActiveSheet
With ws
'~~> Clear Col D and Col F Contents
.Range("D:D,F:F").ClearContents
'~~> Find the last row of col E
lRow = .Range("E" & .Rows.Count).End(xlUp).Row
'~~> Set your range
Set rng = Range("E1:E" & lRow)
'~~> Check if the cells have inconsistent formulas
For Each cl In rng
If cl.Errors(xlInconsistentFormula).Value Then
If errCells Is Nothing Then
Set errCells = cl
Else
Set errCells = Union(cl, errCells)
End If
End If
Next cl
'~~> Display relevant message
If Not errCells Is Nothing Then
ErrorCells = errCells.Address
MsgBox "Formulas in cells " & ErrorCells & " are inconsitent"
Else
MsgBox "All Formulas are consistent"
End If
End With
'~~> Delete temp sheet
Application.DisplayAlerts = False
ws.Delete
Application.DisplayAlerts = True
End Sub
A quick and pragmatic way would be to use another column (temporarily):
Assuming you want to check that each cell in column E has the formula =SUM(A1:D1), simply enter the formula =(SUM(A1:D1)-E1 in another column. Then select the column and filter for FALSE- this will give you all the formulas that have different results!