I am new in and is trying to give an automated ID in which i used the following code:
y = 0
If txtdsgnation = "Plumbing" Then
x = "P"
Do Until Cells(i, 3) = ""
If Cells(i, 3) = "Plumbing" Then
y = y + 1
End If
i = i + 1
Loop
End If
If txtdsgnation = "Electricity" Then
x = "E"
Do Until Cells(i, 3) = ""
If Cells(i, 3) = "Electricity" Then
y = y + 1
End If
i = i + 1
Loop
End If
If txtdsgnation = "Fittings" Then
x = "F"
Do Until Cells(i, 3) = ""
If Cells(i, 3) = "Fittings" Then
y = y + 1
End If
i = i + 1
Loop
End If
If txtdsgnation = "Lift maintenance" Then
x = "L"
Do Until Cells(i, 3) = ""
If Cells(i, 3) = "Lift maintenance" Then
y = y + 1
End If
i = i + 1
Loop
End If
z = 100 + y
txtID = x + "-" + z
The thing i am trying to do is that if i add a new employee, for example a plumber and I already have 2 plumbers txtID will automatically become "P-102"
Thanks in advance
In the loop, the y is always getting initialized with 0. So, y has no chance to become more than 1. Please try to put the y out of the loop.
Related
I have a list of 1000+ names in a single column in excel where the names repeat occasionally. I am trying to count how many times each name occurs. This is what I have currently and it populates the desired sheet but it seems to mess up when counting the number of times the names show up. Anything helps!
m = 2
n = 1
person = Worksheets("Sheet1").Cells(m, 6).Value
Worksheets("Sorted_Data").Cells(n, 2).Value = person
Worksheets("Sorted_Data").Cells(n, 3).Value = 1
n = n + 1
m = m + 1
For i = 0 To Total_Tickets
person = Worksheets("Sheet1").Cells(m, 6).Value
y = 1
d = 0
Do While d <= i
comp = Worksheets("Sorted_Data").Cells(y, 2).Value
x = StrComp(person, comp, vbTextCompare)
If x = 0 Then
Worksheets("Sorted_Data").Cells(n - 1, 3).Value = Worksheets("Sorted_Data").Cells(n - 1, 3).Value + 1
m = m + 1
d = 10000
ElseIf x = 1 Or x = -1 Then
If comp = "" Then
Worksheets("Sorted_Data").Cells(n, 2).Value = person
Worksheets("Sorted_Data").Cells(n, 3).Value = 1
n = n + 1
m = m + 1
d = 10000
End If
y = y + 1
d = d + 1
End If
Loop
Next i
You're managing a lot of counters there, and that makes the logic more difficult to follow.
You could consider something like this instead:
Sub Tester()
Dim wsData As Worksheet, wsList As Worksheet, arr, m, i As Long, nm
Set wsData = ThisWorkbook.Sheets("Sheet1")
Set wsList = ThisWorkbook.Sheets("Sorted_Data")
'grab all the names in an array
arr = wsData.Range("A2:A" & wsData.Cells(Rows.Count, "A").End(xlUp).Row).Value
For i = 1 To UBound(arr, 1) 'loop over the array
nm = arr(i, 1) 'grab the name
m = Application.Match(nm, wsList.Columns("A"), 0) 'existing name on the summary sheet?
If IsError(m) Then
'name was not found: add it to the summary sheet
With wsList.Cells(Rows.Count, "A").End(xlUp).Offset(1)
.Value = nm
m = .Row
End With
End If
With wsList.Cells(m, "B")
.Value = .Value + 1 'update the count
End With
Next i
End Sub
so I am getting errors for some reason "next without for"
here is the code:
Sub test()
Dim y As Integer
y = 0
For i = 1 To 7
For j = 1 To 7
If Cells(i, 1) = Cells(j, 1) Then
y = y + 1
Next j
Cells(i, 2).Value = y
y = 0
Next i
End Sub
The problem doesn't come from your For ... To ... Next but from your If condition that you forgot to close with the End If instruction.
Sub test()
Dim y As Integer
y = 0
For i = 1 To 7
For j = 1 To 7
If Cells(i, 1) = Cells(j, 1) Then
y = y + 1
End If 'You forgot to end the condition
Next j
Cells(i, 2).Value = y
y = 0
Next i
End Sub
I'm getting "error13 type mismatch" when iterating over all worksheets in the workbook in line 7 of the code (If ActiveSheet.Cells(1, 47) = 1 Then). Does anyone know how to fix this?
Dim y As Integer
Dim c As Integer
Dim ws_num As Integer
Dim starting_ws As Worksheet
Set starting_ws = ActiveSheet 'remember which worksheet is active in the beginning
ws_num = ThisWorkbook.Worksheets.Count
For y = 1 To ws_num
ThisWorkbook.Worksheets(y).Activate
If ActiveSheet.Cells(1, 47) = 1 Then
Worksheets("Podsumowanie").Cells(2, y + 1) = ThisWorkbook.Worksheets(y).Range("U2")
Worksheets("Podsumowanie").Cells(3, y + 1) = ThisWorkbook.Worksheets(y).Range("V2")
Worksheets("Podsumowanie").Cells(4, y + 1) = ThisWorkbook.Worksheets(y).Range("W2")
Worksheets("Podsumowanie").Cells(5, y + 1) = ThisWorkbook.Worksheets(y).Range("P3")
Worksheets("Podsumowanie").Cells(6, y + 1) = ThisWorkbook.Worksheets(y).Range("Q3")
Worksheets("Podsumowanie").Cells(7, y + 1) = ThisWorkbook.Worksheets(y).Range("R3")
Worksheets("Podsumowanie").Cells(8, y + 1) = ThisWorkbook.Worksheets(y).Range("S3")
Else
Worksheets("Podsumowanie").Cells(2, y + 1) = ThisWorkbook.Worksheets(y).Range("U2")
Worksheets("Podsumowanie").Cells(3, y + 1) = ThisWorkbook.Worksheets(y).Range("V2")
Worksheets("Podsumowanie").Cells(4, y + 1) = ThisWorkbook.Worksheets(y).Range("W2")
Worksheets("Podsumowanie").Cells(5, y + 1) = ThisWorkbook.Worksheets(y).Range("P8")
Worksheets("Podsumowanie").Cells(6, y + 1) = ThisWorkbook.Worksheets(y).Range("Q8")
Worksheets("Podsumowanie").Cells(7, y + 1) = ThisWorkbook.Worksheets(y).Range("R8")
Worksheets("Podsumowanie").Cells(8, y + 1) = ThisWorkbook.Worksheets(y).Range("S8")
End If
Next
Try using this instead
Dim y As Long
Dim PodSheet As Worksheet
Set PodSheet = ThisWorkbook.Sheets("Podsumowanie")
For y = 1 To ThisWorkbook.Worksheets.Count
With ThisWorkbook.Sheets(y)
If .Cells(1, 47).Value2 = 1 Then
PodSheet.Cells(2, y + 1) = .Range("U2")
PodSheet.Cells(3, y + 1) = .Range("V2")
PodSheet.Cells(4, y + 1) = .Range("W2")
PodSheet.Cells(5, y + 1) = .Range("P3")
PodSheet.Cells(6, y + 1) = .Range("Q3")
PodSheet.Cells(7, y + 1) = .Range("R3")
PodSheet.Cells(8, y + 1) = .Range("S3")
Else
PodSheet.Cells(2, y + 1) = .Range("U2")
PodSheet.Cells(3, y + 1) = .Range("V2")
PodSheet.Cells(4, y + 1) = .Range("W2")
PodSheet.Cells(5, y + 1) = .Range("P8")
PodSheet.Cells(6, y + 1) = .Range("Q8")
PodSheet.Cells(7, y + 1) = .Range("R8")
PodSheet.Cells(8, y + 1) = .Range("S8")
End If
End With
Next y
Type Mismatch error is caused when Cells(1, 47) contains an error - to avoid it use IsError()
Another issue will be caused when the cell is empty or doesn't contain a number
You can also minimize repetition like in Tom's answer, and not .Activate each sheet
This contains all suggestions, but is not tested (you didn't include the full procedure)
Dim y As Long, c As Long, thisCol As Long, pCol As Long
Dim ws As Worksheet, podWs As Worksheet, cel As Range
Set podWs = ThisWorkbook.Worksheets("Podsumowanie")
For Each ws In ThisWorkbook.Worksheets
With ws
pCol = .Index + 1
podWs.Cells(2, pCol) = .Range("U2")
podWs.Cells(3, pCol) = .Range("V2")
podWs.Cells(4, pCol) = .Range("W2")
Set cel = .Cells(1, 47)
If Not IsError(cel) Then
If IsNumeric(cel.Value2) Then
thisCol = IIf(cel = 1, 3, 8)
podWs.Cells(5, pCol) = .Range("P" & thisCol)
podWs.Cells(6, pCol) = .Range("Q" & thisCol)
podWs.Cells(7, pCol) = .Range("R" & thisCol)
podWs.Cells(8, pCol) = .Range("S" & thisCol)
End If
End If
End With
Next
I am trying to construct and If statement that turns a tab Red if two of three cells are colored, or Turns green if only on is colored. I was hoping that there would be an easier way to right it than three if statements like this.
Dim dateRng As String, num As Integer, j As Integer, irng As Range, frng As Range
dateRng = Sheets("Input Raw Data").Range("B" & counter + 2).Value
num = Sheets("Tool Setup").Range("C18").Value
NumPts = num * 3
For s = 1 To Sheets.Count
With Sheets(s)
For j = 1 To num
If .Name = j Then
.Range("A1:C1").Merge
.Range("A1") = dateRng
.Name = Sheets("Point Names").Range("B" & (3 * j - 1))
End If
Next j
End With
Next s
For s = 1 to Sheets.Count
With Sheets(s)
For y = 1 To NumPts
If .Name = Sheets("Reporting").Range("B" & (12 * y - 5)) Then
For k = 6 To -1
Set irng = Sheets("Reporting").Range("A" & (12 * y - k))
Set irng = Sheets("Reporting").Range(irng, irng.End(xlToRight).End(xlToRight))
irng.Copy (.Range("A2"))
Next k
.Columns("A:A").ColumnWidth = 12
.Columns("B:B").EntireColumn.AutoFit
If .Range("B7").Interior.ColorIndex > 0 Then
a = 1
End If
If .Range("B8").Interior.ColorIndex > 0 Then
a = a + 1
End If
If .Range("B9").Interior.ColorIndex > 0 Then
a = a + 1
End If
If a >= 2 Then
.Tab.ColorIndex = 3
ElseIf a <= 1 Then
.Tab.ColorIndex = 4
End If
End If
y = y + 2
Next y
End With
Next s
Something like this may help you. It still has multiple if statements. But the statements are simple and don't have to deal with how the combinations of different cells being colored.
Also, I used colorindex > 0 as the condition for having color filling.
a = 0
If .Range("B7").Interior.ColorIndex > 0 Then
a = 1
End If
If .Range("B8").Interior.ColorIndex > 0 Then
a = a + 1
End If
If .Range("B9").Interior.ColorIndex > 0 Then
a = a + 1
End If
If a = 2 Then
.Range("B10").Interior.ColorIndex = 3
ElseIf a = 1 Then
.Range("B10").Interior.ColorIndex = 43
End If
I have a Macro being run on a worksheet every minute. It copies and pastes data from another worksheet and updates an existing chart.
There is a command button provided which can change the range of x & y series on that chart.
When user clicks on the command button, a userform is shown for user entry of minimum and maximum range.
But as the macro is running every second, userform focus is lost during the macro run and user has to select the user form every time. Its very annoying.
The macro does not select/activate any cell/chart on the worksheet.
How do I stop User form losing it's focus and keep it active in spite of any program running at back end?
this is the code that runs every second. 'Limits' is the user form name.
Sub doitagain()
If Len(Dir(path1 + "\mon")) <> 0 Then
If Limits.Visible Then
Limits.rangecb1.SetFocus
End If
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Interactive = False
fromcopy = path1 + "\mon"
tocopy = path + "\mon.csv"
On Error Resume Next
FileCopy fromcopy, tocopy
filepath = path + "\mon.csv"
Set wtarget = Workbooks.Open(filepath)
wtarget.Windows(1).Visible = False
curiteration = m - 2
i = ii + 1
n = 1
Do While wtarget.Worksheets("mon").Cells(i, 2).Value <> curiteration
i = i + 1
n = n + 1
If n > ThisWorkbook.Worksheets("Convergence_Plot").Cells(1, 6).Value Then
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.Interactive = True
Workbooks("mon.csv").Close savechanges = False
GoTo abc
End If
Loop
j = i
Do While wtarget.Worksheets("mon").Cells(j, 1).Value <> ""
j = j + 1
Loop
j = j - 1
mi = m
For k = i To j
ThisWorkbook.Worksheets("Convergence_Plot").Cells(mi, 1).Value = wtarget.Worksheets("mon").Cells(k, 2).Value
mi = mi + 1
Next
lastcol = 1
Do While wtarget.Worksheets("mon").Cells(i, lastcol).Value <> ""
lastcol = lastcol + 1
Loop
lastcol = lastcol - 1
mi = m
For k = i To j
ThisWorkbook.Worksheets("Convergence_Plot").Cells(mi, 4).Value = wtarget.Worksheets("mon").Cells(k, lastcol - noofsubsdoagain).Value
mi = mi + 1
Next
mi = m
For k = i To j
ThisWorkbook.Worksheets("Convergence_Plot").Cells(mi, 3).Value = wtarget.Worksheets("mon").Cells(k, lastcol - 1 - noofsubsdoagain).Value
mi = mi + 1
Next
mi = m
For k = i To j
ThisWorkbook.Worksheets("Convergence_Plot").Cells(mi, 2).Value = wtarget.Worksheets("mon").Cells(k, lastcol - 2 - noofsubsdoagain).Value
mi = mi + 1
Next
For k = 1 To noofsubsdoagain
mi = m
Dim ki As Integer
For ki = i To j
ThisWorkbook.Worksheets("Convergence_Plot").Cells(mi, 4 + k).Value = wtarget.Worksheets("mon").Cells(ki, lastcol - noofsubsdoagain + k).Value
mi = mi + 1
Next
Next
Application.Interactive = True
Set wtarget = Nothing
Workbooks("mon.csv").Close savechanges = False
mi = m
For k = i To (j - 1)
m = m + 1
Next
i = 3
Do While ThisWorkbook.Worksheets("Convergence_Plot").Cells(i, 1).Value <> ""
i = i + 1
Loop
If i > 3 Then
i = i - 1
End If
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.Interactive = True
If ThisWorkbook.Worksheets("Convergence_Plot").Cells(1, 5).Value = 1 Then
ThisWorkbook.Worksheets("Convergence_Plot").TextBox1.Value = i - 2
Else
ThisWorkbook.Worksheets("Convergence_Plot").TextBox1.Value = i - (ThisWorkbook.Worksheets("Convergence_Plot").Cells(1, 7).Value - ThisWorkbook.Worksheets("Convergence_Plot").Cells(1, 6).Value + 2)
End If
ThisWorkbook.Worksheets("Convergence_Plot").ChartObjects("Chart 1").Chart.FullSeriesCollection(1).XValues = "=Convergence_Plot!$A$3:$A$" & i
ThisWorkbook.Worksheets("Convergence_Plot").ChartObjects("Chart 1").Chart.FullSeriesCollection(1).Values = "=Convergence_Plot!$B$3:$B$" & i
ThisWorkbook.Worksheets("Convergence_Plot").ChartObjects("Chart 1").Chart.FullSeriesCollection(2).Values = "=Convergence_Plot!$C$3:$C$" & i
ThisWorkbook.Worksheets("Convergence_Plot").ChartObjects("Chart 1").Chart.FullSeriesCollection(3).Values = "=Convergence_Plot!$D$3:$D$" & i
Dim letter As String
letter = "D"
For k = 1 To 10
ThisWorkbook.Worksheets("Convergence_Plot").ChartObjects("Chart 1").Chart.FullSeriesCollection(3 + k).Values = "=Convergence_Plot!$" & Chr(Asc(letter) + k) & "$3:$" & Chr(Asc(letter) + k) & "$" & i
Next
If Limits.Visible Then
Limits.rangecb1.SetFocus
End If
End If
abc:
timetorun = Now + TimeValue("00:00:03")
Application.OnTime timetorun, "doitagain", , True
End Sub