my first post here. You guys have helped me million times, but this time I haven't managed to find the answer in google or here.
I created 2 for loops, one inside the other in Excel, shortened version here:
For r = 3 To 25
For col = rota_current_col To 100
Debug.Print "Current position:" & r & "," & col // + some code later
Next col
//some code
Next r
And first loop is not working at all. I'm not touching any of those values (r,col) in code inside loops. This debug print shows values form 3,7 to 3,100 but it's not looping to forth 'r' value.
I hope that is clear enough, thanks in advance!.
EDIT 1: Full loop as requested:
For r = 3 To 25 ' NOT WORKING :(
For col = rota_current_col To 100
Debug.Print "Current position:" & r & "," & col & " current Rota position: " & rota_current_row & "," & rota_current_col & " current Comp position: " & comp_current_row & "," & comp_current_col
Select Case Cells(rota_current_row, rota_current_col)
Case "U", "UZ", "U1", "UZ1"
If Cells(rota_current_row, rota_current_col) <> Cells(comp_current_row, comp_current_col) Then
result.Cells(current, 1) = rota.Cells(rota_current_row, 1)
result.Cells(current, 2) = rota.Cells(rota_current_row, 2)
result.Cells(current, 3) = rota.Cells(rota_current_row, 3)
result.Cells(current, 4) = rota.Cells(rota_current_row, rota_current_col)
result.Cells(current, 5) = rota.Cells(rota_current_row, rota_current_col).Address
result.Cells(current, 6) = comp.Cells(comp_current_row, comp_current_col)
result.Cells(current, 7) = comp.Cells(comp_current_row, comp_current_col).Address
current = current + 1
End If
End Select
rota_current_col = rota_current_col + 1
comp_current_col = comp_current_col + 1
Next col
rota_current_row = rota_current_row + 1
comp_current_row = comp_current_row + 1
Next r
Would you like me to paste full code?
the r will not go to 4 until col = 100. The inner loop needs to finish and then the outer loop starts.
try this
Sub yo()
r = 3
For col = rota_current_col To 100
Debug.Print "Current position:" & r & "," & col
r = r + 1
If r = 26 Then Exit Sub
Next col
End Sub
Related
I need a message displayed in the status bar. I have written the below code. It is freezing Excel after displaying up to 300+.
The main sheet has 20K+ data and copying is taking around 10 minutes.
It will be good if the status bar can show it.
I thought of using a Progress Bar, but it will also freeze.
Sub Split_Consolidate_Data()
Call Delet_Split_Consolidated_Old_Date
Dim xRange1 As Range
Dim I As Long
Dim J As Long
Dim K As Long
I = ActiveWorkbook.Worksheets("Consolidated Data").UsedRange.rows.Count
Set xRange1 = ActiveWorkbook.Worksheets("Consolidated Data").Range("AA2:AA" & I)
J = 1
L = 1
M = 1
n = 1
O = 1
P = 1
On Error Resume Next
Application.ScreenUpdating = False
For K = 1 To xRange1.Count
Application.StatusBar = "Copying " & K & ""
If (CStr(xRange1(K).Value) = 1) Then
xRange1(K).EntireRow.Copy Destination:=Worksheets("Week 1").Range("A" & J + 1)
J = J + 1
ElseIf (CStr(xRange1(K).Value) = 2) Then
xRange1(K).EntireRow.Copy Destination:=Worksheets("Week 2").Range("A" & L + 1)
L = L + 1
ElseIf (CStr(xRange1(K).Value) = 3) Then
xRange1(K).EntireRow.Copy Destination:=Worksheets("Week 3").Range("A" & M + 1)
M = M + 1
ElseIf (CStr(xRange1(K).Value) = 4) Then
xRange1(K).EntireRow.Copy Destination:=Worksheets("Week 4").Range("A" & n + 1)
n = n + 1
ElseIf (CStr(xRange1(K).Value) = 5) Then
xRange1(K).EntireRow.Copy Destination:=Worksheets("Week 5").Range("A" & O + 1)
O = O + 1
ElseIf (CStr(xRange1(K).Value) = 6) Then
xRange1(K).EntireRow.Copy Destination:=Worksheets("Week 6").Range("A" & P + 1)
P = P + 1
End If
Next
Application.ScreenUpdating = True
End Sub
How can I get rid of the freeze or is there any other way I can see how much has processed?
I have a year calendar in Excel along the lines of the following:
-- Tom -- Dick -- Harry
1 -- x -----------------
2 -- x -----------------
3 -- x -----------------
4 --------x-----------
5 --------x-----------
6 --------x-----------
7 x------------------x
8 x------------------x
9 x------------------x
My data consists of blank cells followed by groups of continuous entries.
I would like to extract and show the first and last dates associated with each grouping of entries. So ideally the output of the function would read:
Tom: 1 to 3 & 7 to 9
Dick: 5 to 8
Harry: 9 to 12
or something to that effect!
Solutions involving VBA or native excel functions would be very much appreciated.
Thank-you all for your time!
Sample data:
Macro:
Sub Test()
Dim i As Long, j As Long, k As Long
Dim mystring As String
For j = 2 To 4 'columns
For i = 2 To 13 'rows
If Cells(i, j).Value = "x" Then
For k = i + 1 To 13 + 1
If Not Cells(k, j).Value = "x" Then
If mystring = "" Then
mystring = Cells(1, j).Value & " " & i - 1 & " to " & k - 2
i = k - 1
Exit For
Else
mystring = mystring & " & " & Cells(1, j).Value & " " & i - 1 & " to " & k - 2
i = k - 1
Exit For
End If
End If
Next k
End If
Next i
Worksheets("Sheet2").Range("A" & j - 1).Value = mystring
mystring = ""
Next j
End Sub
Immediate window:
you could use this Function():
Function ExtractFirstAndLast(colIndex As Long)
Dim area As Range
With Range(Cells(1, colIndex), Cells(Rows.Count, colIndex).End(xlUp))
.AutoFilter field:=1, Criteria1:="<>"
If Application.WorksheetFunction.Subtotal(103, .Cells) > 1 Then
ExtractFirstAndLast = .Cells(1, 1) & ":"
For Each area In .Resize(.Rows.Count - 1).Offset(1).SpecialCells(xlCellTypeVisible).Areas
ExtractFirstAndLast = ExtractFirstAndLast & " " & Cells(area.Rows(1).row, 1) & " to " & Cells(area.Rows(area.Rows.Count).row, 1) & " &"
Next
ExtractFirstAndLast = Left(ExtractFirstAndLast, Len(ExtractFirstAndLast) - 2)
End If
.AutoFilter
End With
ActiveSheet.AutoFilterMode = False
End Function
to be called by your "main" Sub as:
Sub main()
MsgBox ExtractFirstAndLast(4) ' this would return "Harry: 7 to 9"
MsgBox ExtractFirstAndLast(2) ' this would return "Tom: 1 to 3 & 7 to 9
End Sub
I'm creating a program to randomly assign volunteers to different positions. There are 8 different spots on each date that need to be assigned to different volunteers. I have the code working except I can't seem to figure out how to get rid of duplicates. I added some code that prevents two spots in a row from being duplicates but that's as far as I got.
This is what the sheet looks like: (Notice that on the first date Connor Reilley is listed for two spots of the same position and Pierce Lewin is signed up for two different positions. That has to be changed).
Here is my code:
For j = 2 To jRows
Assign:
If wksCal.Range("C" & j) = "1st Reader" Or wksCal.Range("C" & j) = "2nd Reader" Then
Lector:
iRand = Int((iRows - 2) * Rnd())
If strLec(iRand) = "" Then
GoTo Assign
End If
wksCal.Range("D" & j) = strLec(iRand)
If wksCal.Range("D" & j) = wksCal.Range("D" & j - 1) Then
GoTo Lector
End If
ElseIf wksCal.Range("C" & j) = "EM" Then
EM:
iRand = Int((iRows - 2) * Rnd())
If strEM(iRand) = "" Then
GoTo Assign
End If
wksCal.Range("D" & j) = strEM(iRand)
If wksCal.Range("D" & j) = wksCal.Range("D" & j - 1) Then
GoTo EM
End If
ElseIf wksCal.Range("C" & j) = "Altar Server" Then
Server:
iRand = Int((iRows - 2) * Rnd())
If strAS(iRand) = "" Then
GoTo Assign
End If
wksCal.Range("D" & j) = strAS(iRand)
If wksCal.Range("D" & j) = wksCal.Range("D" & j - 1) Then
GoTo Server
End If
End If
Next j
a suggestion about how to manage the list of volunteers
With wkscal
Dim a()
ReDim a(irows) ' volunteers index list
For s = 1 To 3 ' 3 dates to fill
With .Cells((s - 1) * 8 + 1, 1)
' fill volunteers index list
For i = 1 To irows
a(i) = i
Next
'
For i = 1 To 8 '8 positions to fill per date
'choose an index in the list of remaining valid index
q = Application.RandBetween(1, irows - i + 1)
.Range("D" & i) = strlec(a(q))
' remove the last chosen index from the list
a(q) = a(irows - i + 1)
Next i
End With
Next s
End With
I have the following VBA which is working fine
Worksheets(d).Cells(x, 5).Value = Application.WorksheetFunction.Max(Range("Data!E3:E7"))
This method should be nested in a FOR function such as
For i = 3 To j
Worksheets(d).Cells(x, 5).Value = Application.WorksheetFunction.Max(Range("Data!E3:E5"))
x = x + 1
Next
How can I parse the E3 and E7to be parameter based according to i meaning
E3 = "E" + i
E5 = "E" + i + 2
full example of what I'm trying:
For i = 3 To j
Worksheets(d).Cells(x, 5).Value = Application.WorksheetFunction.Max(Range("Data!E" + i + ":E" + i+2 +"))
x = x + 1
Next
Try
Sheets("Data").Range("E" & i & ":E" & (i + 2))
& is better than + in combining data of various types into a string. Also -- Range is a child of WorkSheet -- so you need to go through the appropriate Sheet object
Note that you can do this directly without a loop
As formula
Worksheets(d).Cells(x, 5).Resize(J - 3 + 1, 1).FormulaR1C1 = "=MAX(Data!R[1]C5:R[" & J - 3 + 1 & "]C5)"
As values
Worksheets(d).Cells(x, 5).Resize(J - 3 + 1, 1).Value = "=MAX(Data!R[1]C5:R[" & J - 3 + 1 & "]C5)"
I have 16k rows of data. There are two columns with time. What i need is to find rows where time doesn't match and move everyhing below in last 3 columns down on one, so at the end I'll have all rows with time match and those that dont would have last 3 columns blank in that row.
here what I have so far, but I'm new to VBA and this doesnt work(
Sub timeline()
Dim y As Long
With ThisWorkbook.Sheets("L5")
y = .Range("G" & .Rows.Count).End(xlUp).Row
End With
x = 2
Do While ThisWorkbook.Sheets("L5").Cells(x, 4) <> ""
If ThisWorkbook.Sheets("L5").Cells(x, 4).Value = ThisWorkbook.Sheets("L5").Cells(x, 7).Value Then
Else: ThisWorkbook.Sheets("L5").Range("Gx:Iy").Select
Selection.Offset(1, 0).Select
y = y + 1
End If
x = x + 1
Loop
The following code should do it. Check whether the right ranges and cells are used; I tried to figure it out from your code:
Sub timeline()
Dim y As Long
With ThisWorkbook.Sheets("L5")
y = .Range("G" & .Rows.Count).End(xlUp).Row
End With
x = 2
Do While ThisWorkbook.Sheets("L5").Cells(x, 4) <> ""
If ThisWorkbook.Sheets("L5").Cells(x, 4).Value = ThisWorkbook.Sheets("L5").Cells(x, 7).Value Then
' nothing
Else
ThisWorkbook.Sheets("L5").Range("G" & Trim(Str(x)) & ":I" & Trim(Str(y))).Cut
ThisWorkbook.Sheets("L5").Range("G" & Trim(Str(x + 1))).Select
ThisWorkbook.Sheets("L5").Paste
y = y + 1
End If
x = x + 1
Loop
End Sub