Hello can someone please tell me what could be the problem in my calendar. So let me explain whats happening. So first im trying to make a scheduler application and im using a WPF scheduler in VB, so to begin with, the tab of a calendar needs to display 3 items (Subject, Professor Name, Courses) so what i need to do is to choose a room first and then drag a subject name from the listbox (like this Sample1) and then next i need to drag a professors name (Sample2) and then heres where the problems starts
So it already displays two items (Subject and Professor) now i need to drag an item from Course listbox, but the problem is whenever I put a course to the tab of a calendar, it becomes like this instead
So the goal here is to show 3 dragged items but instead, it only shows 2 and the course is overwriting the name of the subject. Please help me, thank you! If you want to see the whole codes, heres the link https://drive.google.com/file/d/1fWKisPr9qDh54B4EMdwWJbY3KFgi_xfc/view?usp=sharing
Heres the code of where you can drag the items
'Dragging Data to Calendar
Sub Add_list_item(ByVal list As String)
Delay.Delay(1)
Dim count = 0
For Each item As CalendarItem In Calendar1.GetSelectedItems()
count += 1
If count > 1 Then
Return
Else
Dim get_item_end_time As DateTime = item.EndDate.AddHours(2)
get_item_end_time = get_item_end_time.AddMinutes(30)
Dim item_start_time = item.StartDate
Dim item_end_time = get_item_end_time
Dim item_tooltip = item.StartDate.ToString()
Dim start_time = item.StartDate.ToString("HH:mm tt")
Dim end_time = item.EndDate.ToString("HH:mm tt")
Dim dat_start As Date = item_tooltip
Dim ci As CultureInfo = CultureInfo.CreateSpecificCulture("en-US")
Dim dtfi As DateTimeFormatInfo = ci.DateTimeFormat
dtfi.AbbreviatedDayNames = {"Sun", "1", "2", "3", "4",
"5", "6"}
Dim output_start As String = String.Format(ci, "{0:ddd}", dat_start.AddDays(0))
Dim item_text = CStr(item.Text)
Dim parts As String() = item_text.Split(New String() {Environment.NewLine},
StringSplitOptions.None)
Dim get_item_total_hours = (item.EndDate - item.StartDate).TotalHours
Dim get_start_time As DateTime
Dim get_end_time As DateTime
If get_item_total_hours = 1 Then
get_start_time = item.StartDate.AddMinutes(-30)
get_end_time = item.EndDate.AddMinutes(30)
ElseIf get_item_total_hours = 1.5 Then
get_start_time = item.StartDate.AddHours(-1)
get_end_time = item.EndDate.AddHours(1)
ElseIf get_item_total_hours = 2 Then
get_start_time = item.StartDate.AddHours(-1).AddMinutes(-30)
get_end_time = item.EndDate.AddHours(1).AddMinutes(30)
ElseIf get_item_total_hours = 2.5 Then
get_start_time = item.StartDate.AddHours(-2)
get_end_time = item.EndDate.AddHours(2)
ElseIf get_item_total_hours = 3 Then
get_start_time = item.StartDate.AddHours(-2).AddMinutes(-30)
get_end_time = item.EndDate.AddHours(2).AddMinutes(30)
ElseIf get_item_total_hours = 3.5 Then
get_start_time = item.StartDate.AddHours(-3)
get_end_time = item.EndDate.AddHours(3)
ElseIf get_item_total_hours = 4 Then
get_start_time = item.StartDate.AddHours(-3).AddMinutes(-30)
get_end_time = item.EndDate.AddHours(3).AddMinutes(30)
ElseIf get_item_total_hours = 4.5 Then
get_start_time = item.StartDate.AddHours(-4)
get_end_time = item.EndDate.AddHours(4)
ElseIf get_item_total_hours = 5 Then
get_start_time = item.StartDate.AddHours(-4).AddMinutes(-30)
get_end_time = item.EndDate.AddHours(4).AddMinutes(30)
ElseIf get_item_total_hours = 5.5 Then
get_start_time = item.StartDate.AddHours(-5)
get_end_time = item.EndDate.AddHours(5)
ElseIf get_item_total_hours = 6 Then
get_start_time = item.StartDate.AddHours(-5).AddMinutes(-30)
get_end_time = item.EndDate.AddHours(5).AddMinutes(30)
End If
If (ListBox1_Instructor.Items.Contains(list) = True) Then
Call Check_if_instructor(list)
End If
If parts.Count >= 3 Then
If (instructor_name = True) Then
Call Get_instructor_code(instructor_gender + list)
Call Get_course_name(corSec_id)
Call checkInstructorSchedule(start_time, end_time, output_start, instructor_id)
If (instructor_name = True) Then
If instructor_gender = "Male" Then
instructor_gender = "Mr. "
Else
instructor_gender = "Ms. "
End If
If item.Text <> "" Then
item.Text = parts(0) + vbNewLine + vbNewLine + instructor_gender + list
item.ApplyColor(Color.RoyalBlue)
End If
instructor_name = False
End If
Else
item.ApplyColor(Color.RoyalBlue)
item.Text = list + vbNewLine + vbNewLine + parts(2) + vbNewLine + vbNewLine
End If
ElseIf parts.Count = 1 Then
If (instructor_name = True) Then
Call Get_instructor_code(instructor_gender + list)
Call Get_course_name(corSec_id)
Call checkInstructorSchedule(start_time, end_time, output_start, instructor_id)
If (instructor_name = True) Then
If instructor_gender = "Male" Then
instructor_gender = "Mr. "
Else
instructor_gender = "Ms. "
End If
If item.Text <> "" Then
item.Text = parts(0) + vbNewLine + vbNewLine + instructor_gender + list
item.ApplyColor(Color.RoyalBlue)
End If
instructor_name = False
End If
Else
item.ApplyColor(Color.RoyalBlue)
item.Text = list + vbNewLine + vbNewLine + parts(parts.Count - 1) + vbNewLine + vbNewLine
End If
End If
Calendar1.Invalidate(item)
End If
Next
End Sub
I'm trying to add a couple of simple macros to a file that is a shared excel binary workbook. The problem whenever the file is unshared the macro does not work anymore. The code is as following:
Sub uploadMain()
Dim xlsFile As String
Dim wbResults As Workbook
Dim wbmCall As Workbook
Dim agmtCdCell As Range
Dim amtCldCell As Range
Dim srchRange As Integer
Dim callClmn As Integer
Dim srchString As String
Dim callAmt As String
Dim notFound As String
Dim lastRowNo As Long
Dim srchRowNo As Long
Dim srcRowNo As Long
Dim customView As Boolean
Dim amntReplaced As Boolean
Dim asset_column As Integer
Dim typ
Dim quantity_column As Integer
Dim quantity As Variant
Dim unique_identifier As Integer
Dim lastrow_updated As Integer
Dim lastrow_preupload As Integer
Dim wiersz
Dim asset As String
Dim state As String
Dim old_row As Integer
Dim amp As String
Dim loaded
Dim direction_column As Integer
Dim delivery_type As String
Sheets("Calls").Select
ThisWorkbook.Save
customView = False
amntReplaced = False
Application.ScreenUpdating = False
Set wbmCall = ThisWorkbook
asset_column = Cells.Find(What:="Asset", After:=[A1], LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False).Column
quantity_column = Cells.Find(What:="Quantity", After:=[A1], LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False).Column
srchRange = Cells.Find(What:="Agmt Code", After:=[A1], LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False).Column
direction_column = Cells.Find(What:="Direction", After:=[A1], LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False).Column
xlsFile = Application.GetOpenFilename("Excel Workbooks (*.xls; *.xlsx),*.xls;*.xslx", , "Select Acadia extract to import.", , False)
If xlsFile = "False" Then Exit Sub
Set wbResults = Workbooks.Open(Filename:=xlsFile, UpdateLinks:=0)
' call amtcalled removed
Dim relocList() As Variant
Dim lngPosition As Integer
Dim startingRow As Range
Dim i As Long
Dim temporary_row As Integer
wbmCall.Activate
Dim b As Integer
Sheets("AcadiaFeeds").Select
Dim amp_array()
If Range("J65536").End(xlUp).Row > 2 Then
Cells(Range("J65536").End(xlUp).Row, 10).Select 'last row
lastrow_preupload = Range("J65536").End(xlUp).Row
amp_array = Range(Selection, Selection.End(xlUp))
End If
wbResults.Activate
'________________
For i = 2 To lastrow_preupload
If Range("Z" & i).Value = "Deliver" Then
ActiveSheet.Range("E" & i).Select
Selection.Replace What:="GROSS", Replacement:="OTM", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False, FormulaVersion:=xlReplaceFormula2
Else
ActiveSheet.Range("E" & i).Select
Selection.Replace What:="GROSS", Replacement:="ITM", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False, FormulaVersion:=xlReplaceFormula2
End If
Next i
'_______________________
relocList = Array("Margin Call Amp ID", "Delivery Type", "Amp ID", "Call Type", "Business State", "Valuation Date", "Total Call Amount", "Our Unique Agreement Identifier", "Quantity", "FX Currency", "Security Id", "Type")
Stop
For lngPosition = LBound(relocList) To UBound(relocList)
Set startingRow = ActiveSheet.Rows(1).Find(What:=relocList(lngPosition), After:=[A1], LookIn:=xlValues, LookAt:=xlWhole, _
SearchOrder:=xlByColumns, SearchDirection:=xlNext, MatchCase:=False)
If Not startingRow Is Nothing Then
Columns(startingRow.Column).Select
Selection.Cut
Columns(1).Select
Selection.Insert Shift:=xlToRight
End If
Next lngPosition
Columns(13).Select
Range(Selection, Selection.End(xlToRight)).Select
Selection.Delete
Dim nextone As String
j = 1
i = 2
Do Until i = Range("A65000").End(xlUp).offset(1, 0).Row
If Cells(i, 8).Value = "Partial Disputed" Then
Rows(i).Delete
Else
i = i + 1
End If
If Cells(i, 11).Value = "Deliver" Then Cells(i, 11).Value = "Pledge"
If Cells(i, 1).Value = "PLEDGE" Then
temporary_row = WorksheetFunction.Match(Cells(i, 12), Range("J:J"), 0)
Cells(i, 5) = Cells(temporary_row, 5)
Cells(i, 8) = Cells(temporary_row, 8)
End If
Loop
Dim As String
i = 1
'remove blanks
=======================================================================================================================================================
lastRowNo = Range("A65000").End(xlUp).Row
wbmCall.Activate
Sheets("AcadiaFeeds").Select
If ActiveSheet.FilterMode = True Then ActiveSheet.FilterMode = False 'gdyby komus wpadl do lepetyny glupi pomysl dodawania filtra w Acadia Feeds
srchRowNo = Range("A65000").End(xlUp).Row + 5
If srchRowNo < 10 Then
srchRowNo = 10
lastrow_preupload = 10
End If
Range("L" & srchRowNo).Value = "Uploaded " & Format(Now, "mmm dd, yyyy hh:mm:ss") & " by " & LCase(Environ("USERNAME"))
srcRowNo = 1
i = 1
Do Until i > lastRowNo
Range("A" & srchRowNo & ":K" & srchRowNo).Value = wbResults.Sheets(1).Range("A" & srcRowNo & ":K" & srcRowNo).Value
srchRowNo = srchRowNo + 1
srcRowNo = srcRowNo + 1
i = i + 1
Loop
wbResults.Close SaveChanges:=False
Set wbResults = Nothing
wbmCall.Activate
Set wbmCall = Nothing
ActiveWorkbook.Sheets("Calls").Select
If ActiveSheet.AutoFilterMode = True Then
customView = True
Application.EnableEvents = False
ActiveWorkbook.CustomViews.Add ViewName:="doAcadii", RowColSettings:=True
ActiveSheet.AutoFilterMode = False
Application.EnableEvents = True
End If
ActiveWorkbook.Sheets("AcadiaFeeds").Select
callClmn = 5 'Our Unique Agreement Identifier na sztywno
cTypeClmn = 9 'call type na sztywno w kolumnie 5tej
=======================================================================================================================================================
backAtLoop:
srchRowNo = lastrow_preupload
lastrow_updated = Range("A65000").End(xlUp).Row
Do Until srchRowNo = lastrow_updated + 1
ActiveWorkbook.Sheets("AcadiaFeeds").Select
srchRowNo = srchRowNo + 1
amp = Cells(srchRowNo, callClmn + 5).Value ' amp ID
srchString = Cells(srchRowNo, callClmn).Value 'od dolu bierze unique identifier
callAmt = Cells(srchRowNo, callClmn + 1).Value 'amt called
cType = Cells(srchRowNo, cTypeClmn).Value 'call type
quantity = Cells(srchRowNo, callClmn - 1).Value 'ilosc papierow
state = Cells(srchRowNo, callClmn + 3).Value 'business state pledge accepted
delivery_type = Cells(srchRowNo, callClmn + 6)
typ = Cells(srchRowNo, 1).Value 'margin_call lub pledge
If Cells(srchRowNo, callClmn - 3).Value <> "CASH" Then
asset = Cells(srchRowNo, callClmn - 3).Value ' aktywo
Else:
asset = Cells(srchRowNo, callClmn - 2).Value
End If
Sheets("Calls").Select
Set foundmatchx = Columns(srchRange).Find(What:=srchString, LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False)
If typ = "MARGIN_CALL" Then
If Application.WorksheetFunction.CountIf(Columns(srchRange), srchString) = 0 Then 'sprawdza dany agreement jest w mcalls table
Sheets("AcadiaFeeds").Select
notFound = notFound & "; " & srchString
Range("A" & srchRowNo & ":I" & srchRowNo).Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 65535
.TintAndShade = 0
.PatternTintAndShade = 0
End With
Range("K" & srchRowNo).Value = "Not Found"
ElseIf Application.WorksheetFunction.CountIf(Columns(srchRange), srchString) <> 0 Then
'howMany = Application.WorksheetFunction.CountIf(Columns(srchRange), srchString)
foundmatchx.offset(0, 3).Activate ' aktywuje offset AMT called
If ActiveCell.offset(0, 11) = "Initial" And cType = "Initial" Then 'idk nor care
'nowt to do here
ElseIf cType = "Initial" And Right(srchString, 4) <> "FBCO" Then
ActiveWorkbook.Sheets("AcadiaFeeds").Select 'acadia feeds
Range("A" & srchRowNo & ":E" & srchRowNo).Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 49407
.TintAndShade = 0
.PatternTintAndShade = 0
End With
Range("F" & srchRowNo).Value = "IM call not found"
GoTo nexxtSrchRowNo
ElseIf cType = "Initial" And Right(srchString, 4) = "FBCO" Then
'nowt to do here
Else
Columns(srchRange).FindNext(foundmatchx).offset(0, 3).Activate
End If
Range("J" & srchRowNo).Value = "Already Loaded", Range("A" & srchRowNo & ":I" & srchRowNo).Select
If ActiveCell.Value = callAmt Then
ActiveWorkbook.Sheets("AcadiaFeeds").Select 'acadia feeds
With ActiveWorkbook.Sheets("AcadiaFeeds").Range("A" & srchRowNo & ":I" & srchRowNo).Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 5296274
.TintAndShade = 0
.PatternTintAndShade = 0
End With
Range("K" & srchRowNo).Value = "Already Loaded"
ElseIf ActiveCell.Value <> "" And ActiveCell.Value <> callAmt Then
ActiveWorkbook.Sheets("AcadiaFeeds").Select 'acadia feeds
Range("A" & srchRowNo & ":E" & srchRowNo).Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 49407
.TintAndShade = 0
.PatternTintAndShade = 0
End With
Range("K" & srchRowNo).Value = "Loaded w/ different amt - please investigate"
amntReplaced = True
Else
ActiveCell.Value = callAmt
ActiveCell.offset(0, 20).Value = "loaded from AcadiaFeeds sheet row# " & srchRowNo
End If
Else
MsgBox "Something unexpected happend"
End If
nexxtSrchRowNo:
End If
ActiveWorkbook.Sheets("AcadiaFeeds").Select
If typ = "PLEDGE" Then
Sheets("Calls").Select 'calls
wiersz = foundmatchx.Row
If IsVarArrayEmpty(amp_array) = False Then
j = 1
loaded = "not_loaded"
For j = 1 To UBound(amp_array)
If amp_array(j, 1) = amp Then
loaded = "already_loaded"
j = UBound(amp_array)
End If
Next
Else: loaded = "not_loaded"
End If
Select Case loaded
Case "already_loaded"
If state = "Pledge Accepted" Then
If IsEmpty(Cells(wiersz, quantity_column)) = False And quantity <> Cells(wiersz, quantity_column) Then
Application.Union(Range(Cells(wiersz + 1, srchRange - 2), Cells(wiersz + 1, srchRange - 1)), Range(Cells(wiersz + 1, srchRange + 1), Cells(wiersz + 1, srchRange + 2))).Style = "Good"
Else:
Application.Union(Range(Cells(wiersz, srchRange - 2), Cells(wiersz, srchRange - 1)), Range(Cells(wiersz, srchRange + 1), Cells(wiersz, srchRange + 2))).Style = "Good"
End If
End If
Case "not_loaded"
If delivery_type = Cells(wiersz, direction_column) And IsEmpty(Cells(wiersz, quantity_column)) = True Then
If state = "Pledge Accepted" Then
Application.Union(Range(Cells(wiersz, srchRange - 2), Cells(wiersz, srchRange - 1)), Range(Cells(wiersz, srchRange + 1), Cells(wiersz, srchRange + 2))).Style = "Good"
End If
Cells(wiersz, quantity_column) = quantity
Cells(wiersz, asset_column) = asset
ElseIf delivery_type = Cells(wiersz, direction_column) And IsEmpty(Cells(wiersz, quantity_column)) = False Then
Cells(wiersz, quantity_column).Select
Call MainModule.insertRow
Cells(wiersz + 1, quantity_column) = quantity
Cells(wiersz + 1, asset_column) = asset
If state = "Pledge Accepted" Then
Application.Union(Range(Cells(wiersz + 1, srchRange - 2), Cells(wiersz + 1, srchRange - 1)), Range(Cells(wiersz + 1, srchRange + 1), Cells(wiersz + 1, srchRange + 2))).Style = "Good"
End If
ElseIf delivery_type <> Cells(wiersz, direction_column) Then
howMany = Application.WorksheetFunction.CountIf(Columns(srchRange), srchString)
i = 1
For i = 1 To howMany
Set foundmatchx = Columns(srchRange).FindNext(foundmatchx)
'daje find dla danego agreeementu
temporary_row = foundmatchx.Row
If delivery_type = Cells(temporary_row, direction_column) And IsEmpty(Cells(temporary_row, quantity_column)) = True Then
'1_17 change
If state = "Pledge Accepted" Then
Application.Union(Range(Cells(temporary_row, srchRange - 2), Cells(temporary_row, srchRange - 1)), Range(Cells(temporary_row, srchRange + 1), Cells(temporary_row, srchRange + 2))).Style = "Good"
End If
Cells(temporary_row, quantity_column) = quantity
Cells(temporary_row, asset_column) = asset
i = howMany
End If
Next
End If
End Select
End If
Loop
ActiveWorkbook.Sheets("Calls").Select
'aplikuje filtr spowrotem
If customView = True Then
Application.EnableEvents = False
With ActiveWorkbook.CustomViews("doAcadii")
.Show
.Delete
End With
Application.EnableEvents = True
End If
Application.ScreenUpdating = True
'ponizsze IF dodane 07/30
If amntReplaced = True Then
MsgBox "Acadia extract uploaded, but some calls were loaded with different call amounts." & vbCrLf & _
"Please investigate for issues before saving this spreadsheet."
Else
MsgBox "Acadia extract uploaded!"
End If
End Sub
Sub amtsCalled()
Application.ScreenUpdating = False
Dim relocList() As Variant
Dim lngPosition As Integer
Dim startingRow As Range
Dim i As Long
Dim temporary_row As Integer
wbmCall.Activate
Sheets("AcadiaFeeds").Select
Dim amp_array()
Cells(Range("J65536").End(xlUp).Row, 10).Select 'last row
MsgBox (Cells(Range("J65536").End(xlUp).Row, 10))
amp_array = Range(Selection, Selection.End(xlUp))
wbResults.Activate
relocList = Array("Margin Call Amp ID", "Amp ID", "Call Type", "Business State", "Valuation Date", "Total Call Amount", "Our Unique Agreement Identifier", "Quantity", "FX Currency", "Security Id", "Type")
Stop
For lngPosition = LBound(relocList) To UBound(relocList)
Set startingRow = ActiveSheet.Rows(1).Find(What:=relocList(lngPosition), After:=[A1], LookIn:=xlValues, LookAt:=xlWhole, _
SearchOrder:=xlByColumns, SearchDirection:=xlNext, MatchCase:=False)
If Not startingRow Is Nothing Then
Columns(startingRow.Column).Select
Selection.Cut
Columns(1).Select
Selection.Insert Shift:=xlToRight
End If
Next lngPosition
Columns(12).Select
Range(Selection, Selection.End(xlToRight)).Select
Selection.Delete
Dim nextone As String
i = 2
Do Until i = Range("A65000").End(xlUp).offset(1, 0).Row
For j = 1 To UBound(amp_array)
If Cells(i, 10).Value = amp_array(j, 1) Then GoTo nextone
Next
If Cells(i, 8).Value = "Partial Disputed" Then
Rows(i).Delete
Else
i = i + 1
End If
If Cells(i, 1).Value = "PLEDGE" Then
temporary_row = WorksheetFunction.Match(Cells(i, 11), Range("J:J"), 0)
Cells(i, 5) = Cells(temporary_row, 5)
End If
nextone:
Loop
'remove blanks
On Error GoTo 0
Exit Sub
Application.ScreenUpdating = True
End Sub
Sub ss()
Application.ScreenUpdating = True
End Sub
Function IsVarArrayEmpty(anArray As Variant)
Dim i As Integer
On Error Resume Next
i = UBound(anArray, 1)
If Err.Number = 0 Then
IsVarArrayEmpty = False
Else
IsVarArrayEmpty = True
End If
End Function
Some of the lines are in Polish, is this causing the issue with uploading new macros and working when it's unshared?
It looks like this is by design:
"Once you share a workbook, any Visual Basic project it contains is no longer accessible. Excel can’t deal with multiple users editing the same macros, so it simply prevents changes to those macros. You can’t record new macros, either. However, you can run macros from shared workbooks."
Ref: https://www.oreilly.com/library/view/programming-excel-with/0596007663/ch08s03.html
I have created a spreadsheet which is used to log a lot of data via a userform. In this userform the initial data will always go to a masterdata tab within the spreadsheet. My issue however, is that I have another 3 worksheets, ws2, ws3 and ws4.
Now based on 4 fields within the userform there are 16 possible different outcomes which would decide if this data is also required to be included into ws2 & ws3, or ws3, or ws 2, or ws2 and ws 4, or just ws 4 etc....
The rules are as follows:
Can someone please let me know a way of getting this information across the necessary sheets. Below is my code for the userform
Dim iRow As Long
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim ws3 As Worksheet
Dim ws4 As Worksheet
Dim Nextnum As Long
Dim Xnum As Long
Set ws1 = Worksheets("MasterData")
Set ws2 = Worksheets("X")
Set ws3 = Worksheets("A")
Set ws4 = Worksheets("C")
Nextnum = Sheets("MasterData").Range("A2").End(xlDown).Value + 1
Xnum = Sheets("X").Range("A2").End(xlDown).Value + 1
ANum = Sheets("A").Range("A2").End(xlDown).Value + 1
CNum = Sheets("C").Range("A2").End(xlDown).Value + 1
'find first empty row in database
mrow = ws1.Cells.Find(what:="*", SearchOrder:=xlRows, _
SearchDirection:=xlPrevious, LookIn:=xlValues).Row + 1
'copy the data to the database
ws1.Cells(mrow, 1).Value = Nextnum
ws1.Cells(mrow, 2).Value = Format(Date, "DD/MM/YYYY")
ws1.Cells(mrow, 3).Value = Format(Time, "HH:MM:SS")
ws1.Cells(mrow, 4).Value = CInt(Format(Date, "WW"))
ws1.Cells(mrow, 5).Value = Format(Date, "MMM-YY")
ws1.Cells(mrow, 6).Value = CInt(Format(Date, "YYYY"))
ws1.Cells(mrow, 7).Value = 1
ws1.Cells(mrow, 8).Value = TxtWeight.Value * (1300 / 1000)
ws1.Cells(mrow, 9).Value = Application.WorksheetFunction.VLookup(ComboBrd.Value, Sheets("Lookup Vals").Range("G:H"), 2, False)
ws1.Cells(mrow, 10).Value = Application.UserName
If ComboBrd.Value = "Mn" Then ws1.Cells(mrow, 11).Value = Application.WorksheetFunction.VLookup(ComboCom.Value, Sheets("Lookup Vals").Range("L:N"), 2, False) Else
If ComboBrd.Value = "Pr" Then ws1.Cells(mrow, 11).Value = Application.WorksheetFunction.VLookup(ComboCom.Value, Sheets("Lookup Vals").Range("P:R"), 2, False) Else
If ComboBrd.Value = "Vot" Then ws1.Cells(mrow, 11).Value = Application.WorksheetFunction.VLookup(ComboCom.Value, Sheets("Lookup Vals").Range("P:R"), 2, False)
ws1.Cells(mrow, 12).Value = TxtRecDate.Value
ws1.Cells(mrow, 13).Value = ComboPD.Value
ws1.Cells(mrow, 14).Value = ComboNP.Value
ws1.Cells(mrow, 15).Value = ComboBrd.Value
ws1.Cells(mrow, 16).Value = ComboCom.Value
ws1.Cells(mrow, 17).Value = TxtAdditional.Value
ws1.Cells(mrow, 18).Value = TxtDOD.Value
ws1.Cells(mrow, 19).Value = TxtBn.Value
ws1.Cells(mrow, 20).Value = TxtFS.Value
ws1.Cells(mrow, 21).Value = ComboPrdG.Value
ws1.Cells(mrow, 22).Value = ComboIss.Value
ws1.Cells(mrow, 23).Value = TxtUni.Value
ws1.Cells(mrow, 24).Value = TxtWet.Value
ws1.Cells(mrow, 25).Value = TxtInc.Value
ws1.Cells(mrow, 26).Value = TxtDet.Value
ws1.Cells(mrow, 27).Value = TxtShr.Value
If anyone can help it would be appreciated.
Thanks,
I think select case would be helpful creating an array of worksheets that should be filled out. After just loop through and add the data:
Dim targetWorksheets As Variant
Select Case True
Case c1 And c2 And c3 >= 50 And c4 <= 1: targetWorksheets = Array(ws1, ws2, ws3)
Case c1 And c2 And c3 >= 50 And c4 > 1: targetWorksheets = Array(ws1, ws2, ws3)
'etc ....
Case Else: targetWorksheets = Array(ws1)
End Select
For Each ws In targetWorksheets
mrow = ws.Cells.Find(what:="*", SearchOrder:=xlRows, SearchDirection:=xlPrevious, LookIn:=xlValues).Row + 1
ws.Cells(mrow, 1).Value = Nextnum
ws.Cells(mrow, 2).Value = Format(Date, "DD/MM/YYYY")
ws.Cells(mrow, 3).Value = Format(Time, "HH:MM:SS")
ws.Cells(mrow, 4).Value = CInt(Format(Date, "WW"))
'etc
Next ws
Gr
Making an autograde of sorts for an excel bracket with the guesses of each bracket in the ranges marked. Still clearly work in progress, finally have it running through, but the loop isn't working, it's returning pointSum of 0. Trying to sum += 10 when points is true.
Sub foo()
Dim Player(1 To 35) As String
Player(1) = Range("M2")
Player(2) = Range("M4")
Player(3) = Range("M10")
Player(4) = Range("M12")
Player(5) = Range("M22")
Player(6) = Range("M24")
Player(7) = Range("M32")
Player(8) = Range("M34")
Player(9) = Range("L1")
Player(10) = Range("L3")
Player(11) = Range("L5")
Player(12) = Range("L7")
Player(13) = Range("L9")
Player(14) = Range("L11")
Player(15) = Range("L13")
Player(16) = Range("L15")
Player(17) = Range("L20")
Player(18) = Range("L22")
Player(19) = Range("L24")
Player(20) = Range("L26")
Player(21) = Range("L28")
Player(22) = Range("L30")
Player(23) = Range("L32")
Player(24) = Range("L34")
Player(25) = Range("K2")
Player(26) = Range("K6")
Player(27) = Range("K10")
Player(28) = Range("K14")
Player(29) = Range("K21")
Player(30) = Range("K25")
Player(31) = Range("K29")
Player(32) = Range("J4")
Player(33) = Range("J12")
Player(34) = Range("J23")
Player(35) = Range("J31")
Dim Winner(1 To 18) As String
Winner(1) = "Mohler"
Winner(2) = "Scotter"
Winner(3) = "DKGAY"
Winner(4) = "Lassie"
Winner(5) = "Mohler"
Winner(6) = "Gunnar"
Winner(7) = "Gord'n"
Winner(8) = "Hellmers"
Winner(9) = "Evan Brown"
Winner(10) = "Jerru"
Winner(11) = "Case"
Winner(12) = "Lassie"
Winner(13) = "Mohler"
Winner(14) = ""
Winner(15) = ""
Winner(16) = "Mohler"
Winner(17) = "Mohler"
Winner(18) = ""
Dim Guess(1 To 18) As String
Guess(1) = Player(10)
Guess(2) = Player(14)
Guess(3) = Player(18)
Guess(4) = Player(23)
Guess(5) = Player(25)
Guess(6) = Player(26)
Guess(7) = Player(27)
Guess(8) = Player(28)
Guess(9) = Player(29)
Guess(10) = Player(30)
Guess(11) = Player(31)
Guess(12) = Player(32)
Guess(13) = ""
Guess(14) = ""
Guess(15) = ""
Guess(16) = ""
Guess(17) = ""
Guess(18) = ""
Dim points(1 To 18) As Boolean
points(1) = False
points(2) = False
points(3) = False
points(4) = False
points(5) = False
points(6) = False
points(7) = False
points(8) = False
points(9) = False
points(10) = False
points(11) = False
points(12) = False
points(13) = False
points(14) = False
points(15) = False
points(16) = False
points(17) = False
points(18) = False
Dim pointSum As Double
pointSum = 0
Dim pointValue(1 To 6) As Double
pointValue(1) = 10
pointValue(2) = 20
pointValue(3) = 30
pointValue(4) = 40
pointValue(5) = 50
pointValue(6) = 60
For i = 1 To 12 Step 1
If Guess(i) = Winner(i) Then
points(i) = True And pointSum = pointSum + 10
Else
points(i) = False
End If
Next
Range("O1") = pointSum
MsgBox "Done!"
End Sub
For i = 1 To 12 Step 1
If Guess(i) = Winner(i) Then
points(i) = True And pointSum = pointSum + 10
Else
points(i) = False
End If
Next
Ok, several things.
Step 1
That's the default; the Step part of the For loop definition is usually only included when its value is different than 1. But that won't cause any problems.
points(i) = True And pointSum = pointSum + 10
If I understand your question correctly...
the loop isn't working, it's returning pointSum of 0. Trying to sum += 10 when points is true.
You're not assigning pointSum anywhere. The above line of code is interpreted as follows:
points(i) = (True And (pointSum = pointSum + 10))
In other words:
points(i) = (True And False)
In other words:
points(i) = False
When you make an assignment, the variable being assigned to goes on the left side of the assignment operator (=):
foo = 42 'assigns value 42 to foo
The confusion seems to be that in VBA, the comparison operator is also a = token:
If foo = 42 Then 'true when the value of foo is 42
To increment pointSum by 10 when points(i) is True, you can do this:
If points(i) = True Then pointSum = pointSum + 10
Which can be simplified to:
If points(i) Then pointSum = pointSum + 10
Because the (boolean expression) in If (boolean expression) Then doesn't need to be compared to True or False when you're already working with a Boolean variable.
Hope it helps!