I can't seems make my loop work:
For Each c In ActiveWorkbook.Sheets("appointments").Range("N1:N1000000")
If c = "Test" Then c.EntireRow.Delete
Next
What I want is to delete rows with cell value of Test in Column N.
Dim i As Long
For i = 1000000 To 1 Step -1
If Cells(i, 14).Value = "Test" Then
Rows(i).Delete
End If
Next i
The above will do what you requested, however I would recommend something like this as I'm doubting you have a million rows worth of data:
Dim i As Long
Dim LastRow As Long
LastRow = ActiveCell.SpecialCells(xlCellTypeLastCell).Row
For i = LastRow To 1 Step -1
If Cells(i, 14).Value = "Test" Then
Rows(i).Delete
End If
Next i
Here's my answer and it works fast:
ActiveWorkbook.Sheets("appointments").Range("N1:N1000000").AutoFilter 1, "=Test"
ActiveWorkbook.Sheets("appointments").Range("N2:N1000000").SpecialCells(xlCellTypeVisible).EntireRow.Delete
ActiveWorkbook.Sheets("appointments").AutoFilterMode = False
Related
This should be an easy problem to solve, but I am extremely unfamiliar with VBA so I need some help.
Essentially, I want to copy data given to me (finite column range, but dynamic rows), and paste it transposed into a second sheet within excel. From there, I need to convert all the values in columns D,E,F, and H to fractions out of 12. I'm pretty sure I'm 99% of the way there, but the last step (converting to fraction text) is being performed in the wrong worksheet. I've tried using the .Activate function as well as setting the correct worksheet, but neither work. There's got to be an easy fix to this that I'm missing. Note: this is my first time ever coding in VBA so take it easy on me. Code is below:
Option Explicit
Sub FormatData()
Dim ws As Worksheet
' create a new worksheet, and name it "Master"
Set ws = ThisWorkbook.Worksheets.Add(after:=ThisWorkbook.Worksheets(1))
ws.Name = "Master"
' copy the UsedRange and Transpose
Worksheets("Sheet1").UsedRange.Copy
ws.Range("A1").PasteSpecial xlPasteAll, Transpose:=True
Sheets("Master").Activate
Dim i As Long, N As Long, j As Long
N = Cells(Rows.Count, "D").End(xlUp).Row
j = 2
For i = 2 To N
Cells(i, "D") = WorksheetFunction.Text(Cells(i, "D"), "0 0/12")
j = j + 1
Next i
j = 2
For i = 2 To N
Cells(i, "E") = WorksheetFunction.Text(Cells(i, "E"), "0 0/12")
j = j + 1
Next i
j = 2
For i = 2 To N
Cells(i, "F") = WorksheetFunction.Text(Cells(i, "F"), "0 0/12")
j = j + 1
Next i
j = 2
For i = 2 To N
Cells(i, "H") = WorksheetFunction.Text(Cells(i, "H"), "0 0/12")
j = j + 1
Next i
End Sub
first only do only one loop and do all four conversions inside that one loop. Second, j is not doing anything, you can omit it.
Sub FormatData()
Dim ws As Worksheet
' create a new worksheet, and name it "Master"
Set ws = ThisWorkbook.Worksheets.Add(after:=ThisWorkbook.Worksheets(1))
With ws
.Name = "Master"
' copy the UsedRange and Transpose
Worksheets("Sheet1").UsedRange.Copy
.Range("A1").PasteSpecial xlPasteAll, Transpose:=True
Dim i As Long, N As Long
N = .Cells(.Rows.Count, "D").End(xlUp).Row
For i = 2 To N
.Cells(i, "D") = Application.WorksheetFunction.Text(.Cells(i, "D"), "# ??/12")
.Cells(i, "E") = Application.WorksheetFunction.Text(.Cells(i, "E"), "# ??/12")
.Cells(i, "F") = Application.WorksheetFunction.Text(.Cells(i, "F"), "# ??/12")
.Cells(i, "H") = Application.WorksheetFunction.Text(.Cells(i, "H"), "# ??/12")
Next i
End With
End Sub
Trying to loop through a sheets"data".Range"AM1:AS12" and copy the data to range beginning at BD1 as long as the data doesn't equal "#N/A"
My code works with copying the first column, but doesn't do anything with the data after that. Where am I going wrong?
Set S2 = Sheets("data").Range("AM:AM")
Set S3 = Sheets("data").Range("BD:BD")
Dim i As Integer, j As Integer
j = 1
For i = 1 To 12
If S2.Cells(i, 1).Value <> "#N/A" Then
S3.Cells(j, 2).Value = S2.Cells(i, 1).Value
j = j + 1
End If
Next i
Replace:
<> "#N/A"
By:
Not(Application.WorksheetFunction.IfNa(...))
This works when i tested it.
Sub CopyCell()
Set S2 = Sheets("data").Range("A:A")
Set S3 = Sheets("data").Range("M:M")
Dim i As Integer, j As Integer
For j = 1 To 2
For i = 1 To 12
If S2.Cells(i, j).Value <> "#N/A" Then
S3.Cells(i, j).Value = S2.Cells(i, j).Value
End If
Next i
Next j
Call DeleteBlank
End Sub
Sub DeleteBlank()
Dim x As Integer
Dim y As Integer
For y = 13 To 16 'Range numbers for the columns the data is copied to
For x = 1 To 10 ' Number of cells of data you want to loop through
If Cells(x, y).Value = "" Then
Cells(x, y).Delete Shift:=xlUp
End If
Next x
Next y
End Sub
the best thing to is not to check if it is equal to "#N/A"
The best is to check if it is an error : If Not (IsError(S2.Cells(i, 1).Value)) Then
I am trying to compare values in two lists. I want my code to compare a value in the first list and check all the entries in the second list. If there is a match then the code will print true next to the value in the first list and if not it will print false.
The problem I am having is that my code only compares values that are in the same row.
The code runs and I have tried it on a two smaller lists to make sure the data types are to same and there aren't any extra spaces or commas in the lists that would lead to a "False" output. I have also tried changing the order of the for and if statements but this doesn't work either.
Sub findvalues()
For i = 2 To 16
For j = 2 To 16
If Cells(i, 3).Value = Cells(i, 1).Value Then
Cells(i, 4).Value = "TRUE"
ElseIf Cells(i, 3).Value = Cells(j + 1, 1).Value Then
Cells(i, 4).Value = "TRUE"
Else
Cells(i, 4).Value = "FALSE"
End If
Next j
Next i
End Sub
Here are the two lists I am testing the code on
Slight mods to your code based on the data you provided in columns 1 & 3. As always, things could be improved but this should get you going ...
Sub findvalues()
Dim i As Long, j As Long, bResult As Boolean
For i = 2 To 16
strValueToLookFor = Cells(i, 1)
For j = 2 To 16
bResult = False
If strValueToLookFor = Cells(j, 3).Value Then
bResult = True
Exit For
End If
Next j
Cells(i, 6).Value = bResult
Next i
End Sub
... you may just need to flick the columns over so the first list searches on the second list or vice versa.
I don't see any need for VBA - formulas are the way to go - but to avoid two loops one could do this:
Sub findvalues()
Dim i As Long
For i = 2 To 130
Cells(i, 4).Value = IsNumeric(Application.Match(Cells(i, 1).Value, Range("C2:C130"), 0))
Next i
End Sub
Update: this does not cater for multiple matches.
There are many was to achieve that. one of them is by using IF & COUNTIF
Formula
=IF(COUNTIF($E$2:$E$6,A2)>0,"TRUE","FALSE")
Results:
VBA CODE
Option Explicit
Sub findvalues()
Dim i As Long
Dim rng As Range
With ThisWorkbook.Worksheets("Sheet1") 'Change if needed
Set rng = .Range("A2:A130") 'set rng to includes values from column A, rows 2:130
For i = 2 To 130 'Loop from row 2 to 130
'Check if the values in column C includes in the rng
If Application.WorksheetFunction.CountIf(rng, .Range("C" & i).Value) > 0 Then
.Range("D" & i).Value = "TRUE"
Else
.Range("D" & i).Value = "FALSE"
End If
Next i
End With
End Sub
VBA code to reconcile two lists.
Sub Reconciliation()
Dim endRow As Long
Dim ICount As Long
Dim Match1() As Variant
Dim Match2() As Variant
Dim ws As Worksheet
Set ws = Worksheets("Recon")
ICount = 0
endRow = ws.Cells(ws.Rows.Count, 2).End(xlUp).Row
endRow1 = ws.Cells(ws.Rows.Count, 11).End(xlUp).Row
Match1 = Sheet1.Range("b2:b" & endRow)
Match2 = Sheet1.Range("K2:K" & endRow1)
For i = LBound(Match1) To UBound(Match1)
For j = LBound(Match2) To UBound(Match2)
If Match1(i, 1) = Match2(j, 1) Then
ICount = ICount + 1
Sheet1.Range("C" & i + 1).Value = ICount
Sheet1.Range("L" & j + 1).Value = ICount
Else
End If
Next j
Next i
End Sub
I have created some coding which is designed to loop through a data set and delete rows based on the required criteria. I need help as it deletes the first found matching criteria but doesn't loop through the rest of the data. What am I missing? Many Thanks
Sub RemoveFivePoundException()
Dim I As Integer
Dim LR As Long
Application.ScreenUpdating = False
Sheets("Claims").Select
LR = Cells(Rows.Count, "A").End(xlUp).row
Range("a1").Select
For I = 3 To LR
If Cells(I, 6).Value > 5# And Cells(I, 7) = "Under £5 write off" Then
Cells(I, 1).EntireRow.Delete
End If
Next I
Application.ScreenUpdating = True
End Sub
When deleting rows, you should invert your loop. With every row deletion the index of the next row has changed.
Alter your loop to:
For I = LR To 3 step -1 'Invert loop!
If Cells(I, 6).Value > 5# And Cells(I, 7) = "Under £5 write off" Then
Cells(I, 1).EntireRow.Delete
End If
Next I
Alternatively, you can do:
For I = 3 To LR
If Cells(I, 6).Value > 5# And Cells(I, 7) = "Under £5 write off" Then
Cells(I, 1).EntireRow.Delete
I = I - 1 'To avoid skipping rows.
End If
Next I
As per comments below this second option works, but is bad practice.
I am not sure if the title is correct. Please correct me if you have a better idea.
Here is my problem: Please see the picture.
This excel sheet contains only one column, let's say ColumnA. In ColumnA there are some cells repeat themselvs in the continued cells twice or three times (or even more).
I want to have the excel sheet transformed according to those repeated cells. For those items which repeat three times or more, keep only two of them.
[Shown in the right part of the picture. There are three Bs originally, target is just keep two Bs and delete the rest Bs.]
It's a very difficult task for me. To make it easier, it's no need to delete the empty rows after transformation.
Any kind of help will be highly appreciated. Thanks!
#
Update:
Please see the picture. Please dont delete the items if they show again...
EDITED - SEE BELOW Try this. Data is assumed to be in "Sheet1", and ordered data is written to "Results". I named your repeted data (A, B, C, etc) as sMarker, and values in between as sInsideTheMarker. If markers are not consecutive, the code will fail.
Private Sub ReOrderData()
Dim lLastRow As Long
Dim i As Integer
Dim a As Integer
Dim j As Integer
Dim sMarker As String
Dim sInsideTheMarker As String
'Get number of rows with data:
lLastRow = Worksheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row
j = 0
k = 1
a = 2
'Scan all rows with data:
For i = 1 To lLastRow
If (Worksheets("Sheet1").Cells(i + 1, 1).Value = Worksheets("Sheet1").Cells(i, 1).Value) Then 'If two consecutive cells holds the same value
j = j + 1
If j = 1 Then
k = k + 1
a = 2
sMarker = Worksheets("Sheet1").Cells(i, 1).Value
Worksheets("Results").Cells(k, 1).Value = sMarker
End If
Else 'If not same values in consecutive cells
sInsideTheMarker = Worksheets("Sheet1").Cells(i, 1).Value
Worksheets("Results").Cells(k, a).Value = sInsideTheMarker
a = a + 1
j = 0
End If
Next i
End Sub
EDITION: If you want results in the same sheet ("Sheet1"), and keep the empty rows for results to look exactly as your question, try the following
Private Sub ReOrderData()
Dim lLastRow As Long
Dim i As Integer
Dim a As Integer
Dim j As Integer
Dim sMarker As String
Dim sInsideTheMarker As String
'Get number of rows with data:
lLastRow = Worksheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row
j = 0
k = 1
a = 5
'Scan all rows with data:
For i = 1 To lLastRow
If (Worksheets("Sheet1").Cells(i + 1, 1).Value = Worksheets("Sheet1").Cells(i, 1).Value) Then 'If two consecutive cells holds the same value
j = j + 1
If j = 1 Then
k = i
a = 5
sMarker = Worksheets("Sheet1").Cells(i, 1).Value
Worksheets("Sheet1").Cells(k, 4).Value = sMarker
End If
Else 'If not same values in consecutive cells
sInsideTheMarker = Worksheets("Sheet1").Cells(i, 1).Value
Worksheets("Sheet1").Cells(k, a).Value = sInsideTheMarker
a = a + 1
j = 0
End If
Next i
End Sub
If you can delete the values that have more than two counts, then I suggest that this might work:
Sub count_macro()
Dim a As Integer
Dim b As Integer
a = 1
While Cells(a, 1) <> ""
b = WorksheetFunction.CountIf(Range("A1:A1000"), Cells(a, 1))
If b > 2 Then
Cells(a, 1).Delete Shift:=xlUp
End If
b = 0
a = a + 1
Wend
End Sub
This should do it. It takes input in column A starting in Row 2 until it ends, and ignores more than 2 same consecutive values. Then it copies them in sets and pastes them transposed. If your data is in a different column and row, change the sourceRange variable and the i variable accordingly.
Sub SETranspose()
Application.ScreenUpdating = False
Dim sourceRange As range
Dim copyRange As range
Dim myCell As range
Set sourceRange = range("A2", Cells(Rows.count, 1).End(xlUp))
Dim startCell As range
Set startCell = sourceRange(1, 1)
Dim i As Integer
Dim haveTwo As Boolean
haveTwo = True
For i = 3 To Cells(Rows.count, 1).End(xlUp).Row + 1
If Cells(i, 1).Value = startCell.Value Then
If haveTwo Then
range(startCell, Cells(i, 1)).Copy
startCell.Offset(0, 4).PasteSpecial Transpose:=True
Application.CutCopyMode = False
haveTwo = False
End If
End If
'if the letter changes or end of set, then copy the set over
'If LCase(Left(Cells(i, 1).Value, 1)) <> LCase(startCell.Value) Or _
'i = Cells(Rows.count, 1).End(xlUp).Row + 1 Then
If Len(Cells(i, 1).Value) > 1 Then
Set copyRange = Cells(i, 1)
copyRange.Copy
Cells(startCell.Row, Columns.count).End(xlToLeft).Offset(0, 1).PasteSpecial
Application.CutCopyMode = False
'Set startCell = sourceRange(i - 1, 1)
ElseIf Len(Cells(i, 1).Value) = 1 And Cells(i, 1).Value <> startCell.Value Then
Set startCell = sourceRange(i - 1, 1)
haveTwo = True
End If
Next i
'clear up data
Set sourceRange = Nothing
Set copyRange = Nothing
Set startCell = Nothing
Application.ScreenUpdating = True
End Sub