I have a sheet with 2 tables. I want to find and return the cell of column 1 which has the minimum proteges.
For example, my code would return either Phil,Levy or Sean, Montain in the first run. (then my spreadsheet will add +1 to one of the two - this is already set in excel). etc....
Coach List Protégées
Phil, Levy 7
Sean, Monteine 7
Victor, Chatelais 8
I have write a code but unfortunately ot does it randomly. Any thoughts ?
Code:
Dim Coach As String
Dim ws As Worksheet, t As ListObject, r As Long
For Each t In MyWorksheet.ListObjects
Select Case t.Name
Case "Table1", "Table3", "Table4", "Table6", "Table8", "Table10", "Table12", "Table14", "Table16"
'do nothing
Case Else
'Coach = Application.WorksheetFunction.Min(t.ListColumns(2).Range)--> could use that ?
For r = 1 To t.DataBodyRange.Rows.Count
For r = t.DataBodyRange.Rows.Count To 1 Step -1
If t.DataBodyRange(r, 2) <= t.DataBodyRange(r + 1, 2) Then
Coach = t.DataBodyRange(r , 1)
End If
Next r
End Select
Next t
I think your method needs a variable for the lowest number found as each row is compared.
p = 9999
For r = 1 To t.DataBodyRange.Rows.Count
If t.DataBodyRange(r, 2) <= p Then
p = t.DataBodyRange(r, 2)
Coach = t.DataBodyRange(r, 1)
End If
Next r
Related
I am trying to write a code which has multiple For and If loops. I will try to explain the problem first where the dataset I have is like the following in column 'AH':
0,0,0,0,1,1,2,2,2,2,2,2,1,1,1,0,0,0,0,0,2,2,2,2,2,0,0,..... where the number of 0s, 1s and 2s in a stretch is unknown. What I am trying to find the number of cycles, where a cycle is defined when there has to be atleast 3 0s in a stretch and then has to be atleast 4 2s consecutively. So, to do that, I wrote the code in the following format
Dim M As Single: Dim Count As Integer: Dim A As Integer: Dim B As Integer
M = 2: Count = 0: A =3: B=4
Dim temp As Integer: Dim temp1 As Integer: temp = 0
For L = M To 50
Sheets("Sheet1").Range("AJ" & M) = M
temp = 0
For L1 = L To L + A
temp = temp + Sheets("Sheet1").Range("AH" & L1)
Next L1
If temp = 0 Then
N = L + A
For N1 = N To 60
If Sheets("Sheet1").Range("AH" & N1) = 2 Then
temp1 = 0
For I1 = N1 To N1 + B
temp1 = temp1 + Sheets("Sheet1").Range("AH" & I1)
Next I1
If temp1 = 2 * B Then
flg = True
Exit For
End If
End If
Next N1
Count = Count + 1: M = I1
Sheets("Sheet1").Range("AJ2") = Count
If flg = True Then Exit For
End If
M = M + 1
Next L
Basically, what I am trying to do is find the first 0 and count the sum of 3 consecutive values. If it is 0, then I am searching for 2. When the first 2 is found, it will add up the next 4 terms and if the sum is equal to 2*4, then I will update the count and the code should start look for 0. However, using the 'Exit For' puts me out of all the loops. And if I don't put Exit, then it keep counting the 2s for more times. I am new to VBA and struck with this problem for a long time. Any help on this will be greatly appreciated. Thank you in advance.
I have used Variants in the past for something similar, but it was one dimensional in its solution. I am wondering if utilizing Variants with two dimensions would be feasible.
I have ever changing list of dates that correspond with a week, that will be entered in chronologically. The next column is the count of that week. Column C is the building that it took place in.
For example, the first row shown in the image above takes place the week of "10/2/2016" and there was a count of 8 that week which means the buildings in rows 2-9 are correlated with that week, and it continues on for each corresponding week.
I have the sum of the counts for each year, so for the chart in "E1:G14", I want to count each time the building is counted for each year, respectively. I am just confused as to how to approach it and if Variants would be useful or if using a CountIfs for the ranges would work best.
Thank you in advance.
CODE
Private Sub maybe()
Dim sht As Worksheet: Set sht = Worksheets("Sheet3")
Dim wk_cnt As Double: wk_cnt = sht.Range("A1", sht.Range("A1").End(xlDown)).Rows.Count
Dim bld_cnt As Double: bld_cnt = sht.Range("C2", sht.Range("C2").End(xlDown)).Rows.Count
Dim cnt As Double
Dim yrs_cnt As Double
If sht.Range("D3").Value = "" Then
yrs_cnt = 1
Else:
yrs_cnt = sht.Range("D2", sht.Range("D2").End(xlDown)).Rows.Count
End If
Dim yrsArray As Range
If sht.Range("D3").Value = "" Then
Set yrsArray = sht.Range("D2")
Else:
Set yrsArray = sht.Range("D2", sht.Range("D2").End(xlDown))
End If
Dim vCnts As Variant
ReDim vCnts(1 To 12, 1 To yr_cnt)
vCnts(1, 1) = "Irving Building"
vCnts(2, 1) = "Memorial Building"
vCnts(3, 1) = "West Tower"
vCnts(4, 1) = "Witting Surgical Center"
vCnts(5, 1) = "Madison Irving Surgery Center"
vCnts(6, 1) = "Marley Education Center"
vCnts(7, 1) = "410 South Crouse"
vCnts(8, 1) = "Physicians Office Building"
vCnts(9, 1) = "Crouse Business Center"
vCnts(10, 1) = "Commonwealth Place"
vCnts(11, 1) = "Crouse Garage"
vCnts(12, 1) = "CNY Medical Center"
For x = 1 To yrs_cnt
cnt = 0
For y = 2 To wk_cnt
If Year(sht.Cells(y, 1).Value) = sht.Cells(1, x + 5).Value Then
cnt = cnt + sht.Cells(y, 2).Value
sht.Cells(14, x + 5) = cnt
End If
Next y
Next x
End Sub
EDIT
With Column C
With only Columns A & B
I need the numbers to match the second image, but when I include all three columns it looks like the first image after I group it by years year. How can I fix that?
It looks like your PivotTable is using the "Count" column improperly. Where it says "Count of Count", it's telling you that the number shown is how many lines on your data range fit the selected criteria. I think if you change the Value Field Settings to SUM you will be pleased with the difference. See below:
I previously have a Excel sheet with VBA coding that fills column, row 1 to 10 with the number 1, row 11 to 20 with number 2 and so on. The code I've used is as follows:
Sub fill()
Dim ID
ID = 1
For c = 1 To 34
ActiveWorkbook.Sheets("Sheet1").Cells(c, 1) = ID
ActiveWorkbook.Sheets("Sheet1").Cells(c + 1, 1) = ID
c = c + 1
If (c Mod 10) = 0 Then
ID = ID + 1
End If
Next c
End Sub
Now I want to change it so that the code starts at row 3 onwards. Meaning row 3 to 12 = 1, row 13 to 22 = 2 and so on. So I changed the 'For' statement to:
For c = 3 To 34
But what happens is that the number 1 appears from row 3 to row 10, and then continues with number 2 in row 11 to 20. Not what I was expecting.
Therefore, what would be the best method of changing the code?
If you want exactly the same output but two rows lower, you can use:
Sub fill()
Dim ID
ID = 1
For c = 1 To 34
ActiveWorkbook.Sheets("Sheet1").Cells(c + 2, 1) = ID
ActiveWorkbook.Sheets("Sheet1").Cells(c + 3, 1) = ID
c = c + 1
If (c Mod 10) = 0 Then
ID = ID + 1
End If
Next c
End Sub
If you still only want to go to row 34 but start in row 3, change the 34 to 32 in the above code.
You can also do it without looping and this is easier to adjust the parameters:
Sub fill()
Const NUMBER_OF_ROWS As Long = 34
Const START_ROW As Long = 3
Const ID As Long = 1
Const NUMBER_IN_GROUP As Long = 10
With ActiveWorkbook.Sheets("Sheet1").Cells(START_ROW, 1).Resize(NUMBER_OF_ROWS)
.Value = .Parent.Evaluate("INDEX(INT((ROW(" & .Address & ")-" & START_ROW & ")/" & _
NUMBER_IN_GROUP & ")+" & ID & ",)")
End With
End Sub
When i understand you write, this should work:
You can use the loop how you did at the beginning. and just add plus 2 to c in the ActiveWorkbook.Sheets("Tabelle1").Cells(c + 2, 1) = ID
Sub fill()
Dim ID
ID = 1
For c = 1 To 34
ActiveWorkbook.Sheets("Tabelle1").Cells(c + 2, 1) = ID
ActiveWorkbook.Sheets("Tabelle1").Cells(c + 3, 1) = ID
c= c+1
If (c Mod 10) = 0 Then
ID = ID + 1
End If
Next c
End Sub
something like that should be the simplest way:
Sub fill()
Dim i As Integer
Dim j As Integer
For i = 1 To 4
For j = 1 To 10
ActiveWorkbook.Sheets("Sheet1").Cells(j + (i - 1) * 10 + 2, 1) = i
Next j
Next i
End Sub
EDIT:
No, the simplest way would be type formula into A3:
=ROUNDDOWN(((ROW()-3))/10,0)+1
end drag it donw.
I have two sets of data that need to be matched based on IDs and timestamp (+/- 3 units converted from time), and below is the formula that I've been using in Excel to do the matching. Recently I've had to run this formula on up to 1 million rows in Excel, and it takes a REALLY long time, crashes too. I'm wondering if there is a faster way to do this, if not in Excel?
=INDEX(A:A,MATCH(1,--(B:B=E3)*--(ABS(C:C-F3)<=3),0),1)
Data Set 1:
Column A: States
Column B: IDs
Column C: Timestamp
Data Set 2:
Column D: Email Addresses
Column E: IDs
Column F: Timestamp
Column G: =INDEX(A:A,MATCH(1,--(B:B=E3)*--(ABS(C:C-F3)<=3),0),1)
Goal: Append "States" Column to Data Set 2 matched on IDs and Timestamp (+/- 3 time units) match.
Just don't know how to run this formula on very large data sets.
Place the following VBA routines in a standard code module.
Run the MIAB1290() routine.
This emulates the precise outcome of your INDEX/MATCH formula, but it is much more efficient. On my computer, a million records are correctly correlated and the results displayed in Column G in just 10 seconds.
Public Sub MIAB1290()
Dim lastB&, k&, e, f, z, v, w, vErr, r As Range
With [a2]
Set r = .Resize(.Item(.Parent.Rows.Count - .Row + 1, 5).End(xlUp).Row - .Row + 1, .Item(, .Parent.Columns.Count - .Column + 1).End(xlToLeft).Column - .Column + 1)
lastB = .Item(.Parent.Rows.Count - .Row + 1, 2).End(xlUp).Row - .Row + 1
End With
With r
.Worksheet.Sort.SortFields.Clear
.Sort Key1:=.Item(1, 2), Order1:=1, Key2:=.Item(1, 2), Order2:=1, Header:=xlYes
v = .Value2
End With
ReDim w(1 To UBound(v), 1 To 1)
vErr = CVErr(xlErrNA)
For k = 2 To UBound(v)
e = v(k, 5)
f = v(k, 6)
w(k, 1) = vErr
z = BSearch(v, 2, e, 1, lastB)
If z Then
Do While v(z, 2) = e
If Abs(v(z, 3) - f) <= 3 Then
w(k, 1) = v(z, 1)
Exit Do
End If
z = z + 1
If z > UBound(v) Then Exit Do
Loop
End If
Next
r(1, 8).Resize(r.Rows.Count) = w
End Sub
Private Function BSearch(vA, col&, vVal, ByVal first&, ByVal last&)
Dim k&, middle&
While last >= first
middle = (last + first) / 2
Select Case True
Case vVal < vA(middle, col)
last = middle - 1
Case vVal > vA(middle, col)
first = middle + 1
Case Else
k = middle - 1
Do While vA(k, col) = vA(middle, col)
k = k - 1
If k > last Then Exit Do
Loop
BSearch = k + 1
Exit Function
End Select
Wend
BSearch = 0
End Function
Excel isn't really made for large ammount of data, and probably no code will do it faster for you then a builtin excel formula. In this case, I would sugest you to give a try to the PowerPivot addin, and see how it handles the situation.
Currently I am debugging a piece of code. Currently my code works as intended it assigns a date of to the finaldate variable then looks in the code to delete all dates that are higher than the finaldate variable. Only problem is that the sub procedure needs to be run multiple times in order for this to take effect. For instance when I run through it once it removes about half of the dates, run through it again and it does the same, I usually F5 it about 5 times to confirm its complete. While this is fine in debugging I need to know this will work perfectly everytime.
Sub Remove_Unecessary_Data_1()
Dim ALLCs As Worksheet
Dim DS As Worksheet
Dim finaldate As Date
Set DS = Sheets("Data Summary")
Set ALLCs = Sheets("Asset LLC (Input)")
ALLCs.Select
For y = 1 To 40
If InStr(1, Cells(13, y), "Timestamp of Execution") Then
finaldate = ALLCs.Cells(50, y)
End If
Next
ALLCs.Select
For u = 1 To 40
If InStr(1, Cells(13, u), "Start Date") Then
For p = 2 To 69584
If Cells(p + 14, u) > finaldate Then
Cells(p + 14, u).EntireRow.Delete
End If
Next
End If
Next
end sub
EDIT: Sample Data
Cells(50,y) = 1/12/15
finaldate = Cells(50,Y)
the column headed Start date contains dates that range anywhere from 1/05/15 to 1/30/15.
When working properly all dates after 1/12/15 should have their entire row eliminated.
When deleting rows, you have to work your way from bottom to top, otherwise you end up skipping rows.
For example, you have:
Line 1
>Line 2
Line 3
Line 4
When your code deletes, Line 2, what was "Row" 3 now becomes "Row "2, but you code moves on to see Line 4. Your data now looks like this:
Line 1
Line 3
>Line 4
If you change this bit of your code:
For p = 2 To 69584
If Cells(p + 14, u) > finaldate Then
Cells(p + 14, u).EntireRow.Delete
End If
Next
to this:
For p = 69598 to 16 step - 1
If Cells(p, u) > finaldate Then
Cells(p, u).EntireRow.Delete
End If
Next
Everything should be fine.
*Note: I adjusted your start & end points up by 14, and removed the + 14 from the Cells() reference. No sense in doing the extra math in there...
When you delete a row using:
Cells(p + 14, u).EntireRow.Delete
the row below the deleted row moves up to occupy that space. If that row contains a date that should be deleted it will be ignored because the counter automatically moves onto the next row. For example, say we wish to delete any rows with C or D in the Data column:
Row Number Data
1 A
2 B
3 C
4 D
5 E
becomes:
Row Number Data
1 A
2 B
3 D
4 E
Tthe row counter moves onto 4 without checking the new value in 3 so the D will not be deleted.
You can solve this by changing your If...Then statement to a Do...While loop:
Sub Remove_Unecessary_Data_1()
Dim ALLCs As Worksheet
Dim DS As Worksheet
Dim finaldate As Date
Set DS = Sheets("Data Summary")
Set ALLCs = Sheets("Asset LLC (Input)")
ALLCs.Select
For y = 1 To 40
If InStr(1, Cells(13, y), "Timestamp of Execution") Then
finaldate = ALLCs.Cells(50, y)
End If
Next
ALLCs.Select
For u = 1 To 40
If InStr(1, Cells(13, u), "Start Date") Then
For p = 2 To 69584
Do While (Cells(p + 14, u) > finaldate)
Cells(p + 14, u).EntireRow.Delete
Loop
Next
End If
Next
End sub
This should keep checking that cell after it has deleted the previous row to ensure the replacement row should not be deleted also.
The fact that you delete a row while going increasingly in row's number, you will miss to analyze every rows right after the one you just delete because it (rows(i+1)) has become the rows(i) and yet you increased with the next.
Here is your code taking that into account (and got rid of the useless Select)
Sub Remove_Unecessary_Data_1()
Dim ALLCs As Worksheet, _
DS As Worksheet, _
FinalDate As Date
Set DS = Sheets("Data Summary")
Set ALLCs = Sheets("Asset LLC (Input)")
For y = 1 To 40
If InStr(1, ALLCs.Cells(13, y), "Timestamp of Execution") Then
FinalDate = ALLCs.Cells(50, y)
End If
Next
For u = 1 To 40
If InStr(1, ALLCs.Cells(13, u), "Start Date") Then
For p = 69584 To 2 Step -1
If Cells(p + 14, u) > FinalDate Then
Cells(p + 14, u).EntireRow.Delete
End If
Next
End If
Next
End Sub