I have created the following loop for comparing cell values in different worksheets.
Dim mRng, qRng As Range
Dim i, j As Range
Dim k As Integer
With Worksheets("Content")
Set mRng = .Range(.Range("D2"), .Range("D2").End(xlDown))
End With
With Worksheets("Book")
Set qRng = .Range(.Range("H2"), .Range("H2").End(xlDown))
End With
For Each i In mRng
For Each j In qRng
If i <> j Then
i.Interior.Color = vbRed
MsgBox "Data does not match, please check again!", vbOKOnly
Exit Sub
Else:
i.Interior.Color = vbGreen
End If
Next j
Next i
How can I modify the above codes so that 'i' will also loop together with 'j' each time (i.e. i2 vs j2, i3 vs j3).
Use a long not a range and iterate on that.
'you need to put as type after each variable
Dim worksheet1 As Worksheet, worksheet2 As Worksheet
Dim i As Long, lr As Long
Set worksheet1 = ActiveWorkbook.Worksheets("Content")
Set worksheet2 = ActiveWorkbook.Worksheets("Book")
With worksheet1
lr = .Cells(.Rows.Count, 4).End(xlUp).Row 'get last row
End With
With worksheet2
'make sure the second sheet isn't longer than the first
If .Cells(.Rows.Count, 8).End(xlUp).Row > i Then
lr = .Cells(.Rows.Count, 8).End(xlUp).Row
End If
End With
With worksheet1
For i = 1 To lr 'iterate the row
If .Cells(i, 4).Value <> worksheet2.Cells(i, 8).Value Then
.Cells(i, 4).Interior.Color = vbRed
MsgBox "Data does not match, please check again!", vbOKOnly
Exit Sub
Else
.Cells(i, 4).Interior.Color = vbGreen
End If
Next i
End With
Related
I have this code where i can search for the first two blank cells and place an "x" on the first cell that contains the blank. For testing purposes i have separated the the code into two command buttons. For First command button searches the blank cells and places the "x" and second command button finds the "x" and deletes the row and all other rows after it.
My problem is, i want it to delete all rows after the "x" but to leave the last row which contains the overall Total.
Here is my code from the two command buttons :
Sub findEmptyCells()
Dim lastRow As Long, i As Long
Dim firstEmptyCell As Range
lastRow = Cells(Rows.Count, 12).End(xlUp).Row
For i = 12 To lastRow
If Cells(i, 12).Value = "" And Cells(i + 1, 12).Value = "" Then
Set firstEmptyCell = Cells(i, 12)
Exit For
End If
Next i
MsgBox ("There are no two empty cells in a row")
Exit Sub
End If
firstEmptyCell.Value = "x"
End Sub
Sub Deleterows_Click()
Dim srchRng As Range
Set srchRng = Range("L7:L500")
Dim c As Range
For Each c In srchRng
If c.Value = "x" Then
Range(c, Range("L500")).EntireRow.Delete
Exit For
End If
Next
End Sub
Delete Rows Identified By Merged Cells
Option Explicit
Sub DeleteRows()
Const Col As String = "L"
Const fRow As Long = 13
Const mcCount As Long = 5
Dim ws As Worksheet: Set ws = ActiveSheet ' improve!
Dim lRow As Long: lRow = ws.Cells(ws.Rows.Count, Col).End(xlUp).Row
Dim cCell As Range
Dim r As Long
For r = fRow To lRow - mcCount
'Debug.Print r
Set cCell = ws.Cells(r, Col)
If cCell.MergeArea.Cells.Count = mcCount Then
If Len(CStr(cCell.Value)) = 0 Then
cCell.Offset(-1).Resize(lRow - r + 1).EntireRow.Delete
Exit For
End If
r = r + mcCount - 1
End If
Next r
MsgBox "Rows deleted.", vbInformation
End Sub
I really don't understand much VBA, so be patient with me.
I have a list of people assigned to a specific flight (LEGID) and I want to copy those people (Worksheet pax) to a specific cell in another worksheet (temp - cell b15), but it doesn't work.
This data table is a query report from salesforce.
Sub pax()
Dim LastRow As Long
Dim i As Long, j As Long
Dim legid As String
Application.ScreenUpdating = False
legid = ThisWorkbook.Worksheets("setup").Range("SelReq").Value
Debug.Print legid
'Find the last used row in a Column: column A in this example
With Worksheets("pax")
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
End With
' MsgBox (LastRow)
'first row number where you need to paste values in temp'
With Worksheets("temp")
j = .Cells(.Rows.Count, "a").End(xlUp).Row + 1
End With
For i = 1 To LastRow
With Worksheets("pax")
If .Cells(i, 1).Value = legid Then
.Rows(i).Copy Destination:=Worksheets("temp").Range("a" & j)
j = j + 1
End If
End With
Next i
Application.ScreenUpdating = True
End Sub
If you are looking to just get the names copied over. You can use this; however you will need to update your sheet names and ranges if they are named ranges. This code looks at a specific cell for a value on Sheet3 then if that value matches a value from a range on Sheet1 it will place the values from Column B on Sheet1 into Sheet2
Sub Test()
Dim cell As Range
Dim LastRow As Long, i As Long, j As Long
Dim legid As String
With Sheet1
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
End With
With Sheet2
j = .Cells(.Rows.Count, "A").End(xlUp).Row + 1
End With
legid = Sheet3.Range("A1")
For i = 2 To LastRow
For Each cell In Sheet1.Range("A" & i)
If cell.Value = legid Then
Sheet2.Range("A" & j) = cell.Offset(0, 1).Value
j = j + 1
End If
Next cell
Next i
End Sub
I'm trying to concatenate the values for cells in a given row (say C3:F3) and in that same row (on the same worksheet) go to first empty cell to the left of the cells that were concatenated (say B3) and input the concatenated values. The code below works the first time but I keep on getting a run-time error 1004 when the following line of code is run ws.Range("B3").End(xlDown).Offset(1, 0).Value = varConctnt, that is, the next set of cells in the next row are selected (say C4:F4) and I want to input the concatenated value in cell B4. I've done my best to declare objects to get around the issue but the error keeps on appearing.
Thanks in advance.
Sub ConcatenateReal2()
Dim rng As Range, iRow As Integer, iCol As Integer, i As Integer
Dim ws As Worksheet
Set ws = ActiveSheet
ws.Range("C3").Select
Set rng = ActiveSheet.Range(ActiveCell.End(xlToRight), ActiveCell.End(xlDown))
Dim varConctnt As Variant
For iRow = 1 To rng.Rows.Count
For iCol = 1 To rng.Columns.Count
If Not rng(iRow, iCol).Value = vbNullString Then
varConctnt = varConctnt & "," & rng(iRow, iCol).Value
End If
Next iCol
Range("B3").Activate
If IsEmpty(ActiveCell) Then
ActiveCell.Value = varConctnt
Else
ws.Range("B3").End(xlDown).Offset(1, 0).Value = varConctnt
End If
varConctnt = ""
skip1:
Next iRow
End Sub
(Untested)
Sub ConcatenateReal2()
Dim rng As Range, c As Range
Dim sep, rw as Range, v, s
With ActiveSheet.Range("C3")
Set rng = .Parent.Range(.End(xlToRight), .End(xlDown))
End With
For Each rw in rng.Rows 'loop over rows
sep = "" 'reset separator
s = ""
For Each c in rw.Cells
v = c.value
If Len(v) > 0 Then
s = s & sep & v
sep = ","
end if
next c
rw.cells(1).offset(0, -1).value = s
Next rw
End Sub
I want to remove duplicates based on the text in Column I and sum the values in Column C, the data in the other columns doesn't matter.
I do not want a pivot table and I am aware they are the preferred option for this type of thing.
An example of what I'd like to achieve:
I found VBA code and tried to modify it. It doesn't delete all the lines.
Sub Sum_and_Dedupe()
With Worksheets("data")
'deal with the block of data radiating out from A1
With .Cells(1, 1).CurrentRegion
'step off the header and make one column wider
With .Resize(.Rows.Count - 1, .Columns.Count + 1).Offset(1, 0)
.Columns(.Columns.Count).Formula = "=sumifs(c:c, i:i, i2)"
.Columns(3) = .Columns(.Columns.Count).Value
.Columns(.Columns.Count).Delete
End With
'remove duplicates
.RemoveDuplicates Columns:=Array(9), Header:=xlYes
End With
.UsedRange
End With
End Sub
This should be an answer to your question.
However, code might require adaptation if the range in which you look becomes very long.
Option Explicit
Sub test()
Dim wb As Workbook
Dim ws As Worksheet
Dim LastRow As Long, LastCol As Long, a As Double, i As Long
Dim Rng As Range
Dim Cell As Variant, Estimate As Variant
Set wb = ThisWorkbook
Set ws = wb.Sheets(1)
LastRow = ws.Cells(ws.Rows.Count, "I").End(xlUp).Row
LastCol = ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column
Set Rng = ws.Range(ws.Cells(2, 9), ws.Cells(LastRow, 9))
For Each Cell In Rng
i = 0
a = 0
For Each Estimate In Rng
If Estimate.Value = Cell.Value Then
i = i + 1 'Count nr of intances
a = a + ws.Cells(Estimate.Row, 3).Value 'sum booking value
If i > 1 Then
ws.Rows(Estimate.Row).Delete
i = 1
LastRow = LastRow - 1
End If
End If
Next Estimate
ws.Cells(Cell.Row, 3).Value = a 'Enter sum in booked this week
Next Cell
End Sub
You'll either need to change your current sheet name to data, or change the first two lines of this code to fit your needs. sh = the data sheet that you showed us. osh = an output sheet that this code will generate. Note also if column C or I move you can update the positions easily by changing colBooked and colEstimate. If you have more than a thousand unique estimate entries then make the array number larger than 999.
Sub summariseEstimates()
Dim sh As String: sh = "data"
Dim osh As String: osh = "summary"
Dim colBooked As Integer: colBooked = 3
Dim colEstimate As Integer: colEstimate = 9
Dim myArray(999) As String
Dim shCheck As Worksheet
Dim output As Worksheet
Dim lastRow As Long
Dim a As Integer: a = 0
Dim b As Integer
Dim r As Long 'row anchor
Dim i As Integer 'sheets
'Build summary array:
With Worksheets(sh)
lastRow = .Cells.Find("*", searchorder:=xlByRows, searchdirection:=xlPrevious).Row
For r = 2 To lastRow
If r = 2 Then 'first entry
myArray(a) = .Cells(r, colEstimate) & "," & .Cells(r, colBooked)
Else
For b = 0 To a
If VBA.LCase(VBA.Replace(.Cells(r, colEstimate), " ", "")) = VBA.LCase(VBA.Replace(VBA.Split(myArray(b), ",")(0), " ", "")) Then 'match
myArray(b) = VBA.Split(myArray(b), ",")(0) & "," & VBA.Split(myArray(b), ",")(1) + .Cells(r, colBooked)
Exit For
End If
Next b
If b = a + 1 Then 'completed loop = no match, create new array item:
a = a + 1
myArray(a) = .Cells(r, colEstimate) & "," & .Cells(r, colBooked)
End If
End If
Next r
End With
'Create summary sheet:
On Error Resume Next
Set shCheck = Worksheets(osh)
If Err.Number <> 0 Then
On Error GoTo 0
Set output = Worksheets.Add(After:=Worksheets(sh))
output.Name = osh
Err.Clear
Else
On Error GoTo 0
If MsgBox("*" & osh & "* sheet already exists. Proceed to delete and recreate?", vbOKCancel, "Summary") = vbCancel Then
Exit Sub
Else
Application.DisplayAlerts = False
Worksheets(osh).Delete
Set output = Worksheets.Add(After:=Worksheets(sh))
output.Name = osh
End If
End If
'Output to summary sheet:
With Worksheets(osh)
.Cells(1, 1).Value = "ESTIMATE"
.Cells(1, 2).Value = "BOOKED THIS WEEK"
For b = 0 To a
.Cells(b + 2, 1).Value = VBA.Split(myArray(b), ",")(0)
.Cells(b + 2, 2).Value = VBA.Split(myArray(b), ",")(1)
Next b
.Columns("A:B").AutoFit
End With
End Sub
I found this code on another post that will single out a line - but it deletes all others EXCEPT the specified line.
I work with large numbers of address lists and I need something I can run that will identify and delete rows with addresses that we've been asked not to mail to. I've just discovered VBA some I'm extremely green. But I'd like to have a module that allows me to add multiple addresses as the list grows.
Sub DeleteRows()
Dim i as long, LastRow As long
with activesheet
LastRow = .Cells(.Rows.Count, 1).End(xlUp).row
For i = LastRow to 2 step -1
If .Cells(i, 1).Value <> "certain value" Then
.Rows(i).Delete
End If
Next i
End With
End Sub
Simply change this:
If .Cells(i, 1).Value <> "certain value" Then - where cell value different then "certain value"
to this:
If .Cells(i, 1).Value = "certain value" Then - where cell value equal to "certain value"
Sub DeleteRows()
Dim i As Long, LastRow As Long
With ActiveSheet
LastRow = .Cells(.Rows.count, 1).End(xlUp).row
For i = LastRow To 2 Step -1
If .Cells(i, 1).value = "certain value" Then
.Rows(i).Delete
End If
Next i
End With
End Sub
You could use Union to gather the qualifying rows in one go and delete. Also, have a separate sheet where you store the addresses to match on. Read those addresses into an array, then loop the sheet where data is to be deleted from and check whether a given address is found in your array. If found, use Union to store that cell for later deletion.
At the end of looping the data to check, delete the rows associated with the stored cells in the union'd range object in one go.
Option Explicit
Public Sub DeleteThemRows()
Dim arr(), unionRng As Range, i As Long, lastRow As Long, rng As Range
Dim wsAddress As Worksheet, wsDelete As Worksheet
Set wsAddress = ThisWorkbook.Worksheets("Addresses")
Set wsDelete = ThisWorkbook.Worksheets("DataToDelete")
With wsAddress '<= Assume addresses stored in column A starting from cell A1
lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
Select Case lastRow
Case 1
ReDim arr(1, 1): arr(1, 1) = .Range("A1").Value
Case Is >= 2
arr = .Range("A1:A" & lastRow).Value
End Select
arr = Application.WorksheetFunction.Index(arr, 0, 1)
End With
With wsDelete '<==Assume address column to check is column A
lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
Dim loopRange As Range
Set loopRange = .Range("A1:A" & lastRow)
If Application.WorksheetFunction.CountA(loopRange) = 0 Then Exit Sub
For Each rng In loopRange.SpecialCells(xlCellTypeConstants)
If Not IsError(Application.Match(rng.Value, arr, 0)) Then
If Not unionRng Is Nothing Then
Set unionRng = Union(unionRng, rng)
Else
Set unionRng = rng
End If
End If
Next
End With
If Not unionRng Is Nothing Then unionRng.EntireRow.Delete
End Sub
You could use Debug.Print unionRng.Address first to check what will be deleted.
Sub FastDelete()
Dim rng As Range, rngData As Range, rngVisible As Range
Const CRITERIA$ = "SOME_VALUE"
Set rng = Range("A1").CurrentRegion '//Whole table
With rng '//Table without header
Set rngData = .Offset(1).Resize(.Rows.Count - 1)
End With
'// Filter by column "A"
rng.AutoFilter Field:=1, Criteria1:=CRITERIA
On Error Resume Next '//In case if no values filtered
Set rngVisible = rng.SpecialCells(xlCellTypeVisible)
If Err = 0 Then
rngVisible.EntireColumn.Delete
End If
On Error GoTo 0
End Sub