VBA code message box added

[rich_cirillo]

Hi
Can the following line be added to the code underneath the code line - MsgBox "Cannot transfer until all data entered", vbCritical
End If

after the data has been transferred to the score sheet a Messagebox says "Data has been transferred to the Score sheet"....




Option Explicit

Dim nmFlag As Name

Sub insert_data()

Dim d, i As Long, k, q, x, r As Long, Rng1 As Range
Dim c As Long, lRow As Long, Rng2 As Range, Hdr

lRow = Sheets("SCORE").Range("c" & Sheets("SCORE").Rows.Count).End(3).Row
Set Rng2 = Sheets("SCORE").Range("c3:n" & lRow)
d = Rng2.Value2
q = Application.Index(d, 0, 1)

Set Rng1 = Sheets("WEEKLY_GRAPH").Range("B32:m37")
Hdr = Sheets("WEEKLY_GRAPH").Range("C21:m21")
If Application.WorksheetFunction.CountA(Rng1) = Rng1.Cells.Count Then
k = Rng1.Value2

x = Application.Match(k(1, 1), q, 0)
If Not IsError(x) Then
If Len(d(x, 2)) * Len(d(x, 3)) Then 'check 2 columns whether they have data in those cells
MsgBox "It seems data already been entered for date " & CDate(k(1, 1))
Exit Sub
Else
For r = 1 To UBound(k, 1)
For c = 1 To UBound(k, 2)
d(r + x - 1, c) = k(r, c)
Next
Next
For c = 2 To UBound(d, 2): d(x - 1, c) = Hdr(1, c - 1): Next
End If
Else
Set Rng2 = Sheets("SCORE").Range("c3:m" & lRow + 9)
d = Rng2.Value2
For r = 1 To UBound(k, 1)
For c = 1 To UBound(k, 2)
d(UBound(d, 1) - UBound(k, 1) + r, c) = k(r, c)
Next
Next
For c = 2 To UBound(d, 2): d(UBound(d, 1) - UBound(k, 1), c) = Hdr(1, c - 1): Next
End If
Rng2 = d
Rng2.Columns(1).NumberFormat = "m/d/yyyy"
With Rng2.Resize(Rng2.Rows.Count + 2, Rng2.Columns.Count)
.Rows.RowHeight = 25
End With
On Error Resume Next
Set nmFlag = ThisWorkbook.Names("Flag")
On Error GoTo 0
If nmFlag Is Nothing Then
ThisWorkbook.Names.Add "Flag", "TRUE", 1
Else
nmFlag.RefersTo = "TRUE"
End If
Else
MsgBox "Cannot transfer until all data entered", vbCritical
End If

End Sub

Sub ClearData()

Dim Rng As Range

Set Rng = Sheets("WEEKLY_GRAPH").Range("c32:M36")
On Error Resume Next
Set nmFlag = ThisWorkbook.Names("Flag")
On Error GoTo 0

If Application.WorksheetFunction.CountA(Rng) = Rng.Cells.Count Then
If Evaluate("Flag") Then
Sheets("WEEKLY_GRAPH").Range("c32:M36").ClearContents
If nmFlag Is Nothing Then
ThisWorkbook.Names.Add "Flag", "FALSE", 1
Else
nmFlag.RefersTo = "FALSE"
End If
Else
MsgBox "Transfer the Data first", vbInformation
End If
Else
MsgBox "Cannot be deleted as incomplete", vbCritical
End If

End Sub

[Admin]

Hi

There are so many msgboxes already in the code. Why don't try yourself to write a simple line of code ?

[rich_cirillo]

I did try....failed....so posted here

Thanks

[Admin]

Hi

Let me see your code (what you tried) ?

[rich_cirillo]

Here what I used...



ption Explicit

Dim nmFlag As Name

Sub insert_data()

Dim d, i As Long, k, q, x, r As Long, Rng1 As Range
Dim c As Long, lRow As Long, Rng2 As Range, Hdr

lRow = Sheets("SCORE").Range("c" & Sheets("SCORE").Rows.Count).End(3).Row
Set Rng2 = Sheets("SCORE").Range("c3:n" & lRow)
d = Rng2.Value2
q = Application.Index(d, 0, 1)

Set Rng1 = Sheets("WEEKLY_GRAPH").Range("B32:m37")
Hdr = Sheets("WEEKLY_GRAPH").Range("C21:m21")
If Application.WorksheetFunction.CountA(Rng1) = Rng1.Cells.Count Then
k = Rng1.Value2

x = Application.Match(k(1, 1), q, 0)
If Not IsError(x) Then
If Len(d(x, 2)) * Len(d(x, 3)) Then 'check 2 columns whether they have data in those cells
MsgBox "It seems data already been entered for date " & CDate(k(1, 1))
Exit Sub
Else
For r = 1 To UBound(k, 1)
For c = 1 To UBound(k, 2)
d(r + x - 1, c) = k(r, c)
Next
Next
For c = 2 To UBound(d, 2): d(x - 1, c) = Hdr(1, c - 1): Next
End If
Else
Set Rng2 = Sheets("SCORE").Range("c3:m" & lRow + 9)
d = Rng2.Value2
For r = 1 To UBound(k, 1)
For c = 1 To UBound(k, 2)
d(UBound(d, 1) - UBound(k, 1) + r, c) = k(r, c)
Next
Next
For c = 2 To UBound(d, 2): d(UBound(d, 1) - UBound(k, 1), c) = Hdr(1, c - 1): Next
End If
Rng2 = d
Rng2.Columns(1).NumberFormat = "m/d/yyyy"
With Rng2.Resize(Rng2.Rows.Count + 2, Rng2.Columns.Count)
.Rows.RowHeight = 25
End With
On Error Resume Next
Set nmFlag = ThisWorkbook.Names("Flag")
On Error GoTo 0
If nmFlag Is Nothing Then
ThisWorkbook.Names.Add "Flag", "TRUE", 1
Else
nmFlag.RefersTo = "TRUE"
End If
Else
MsgBox "Cannot transfer until all data entered", vbCritical
End If

MsgBox "Data has been Transferred to Score sheet", vbCritical


End Sub

[Admin]

Hi


Option Explicit

Dim nmFlag As Name

Sub insert_data()

Dim d, i As Long, k, q, x, r As Long, Rng1 As Range
Dim c As Long, lRow As Long, Rng2 As Range, Hdr

lRow = Sheets("SCORE").Range("c" & Sheets("SCORE").Rows.Count).End(3).Row
Set Rng2 = Sheets("SCORE").Range("c3:n" & lRow)
d = Rng2.Value2
q = Application.Index(d, 0, 1)

Set Rng1 = Sheets("WEEKLY_GRAPH").Range("B32:m37")
Hdr = Sheets("WEEKLY_GRAPH").Range("C21:m21")
If Application.WorksheetFunction.CountA(Rng1) = Rng1.Cells.Count Then
k = Rng1.Value2

x = Application.Match(k(1, 1), q, 0)
If Not IsError(x) Then
If Len(d(x, 2)) * Len(d(x, 3)) Then 'check 2 columns whether they have data in those cells
MsgBox "It seems data already been entered for date " & CDate(k(1, 1))
Exit Sub
Else
For r = 1 To UBound(k, 1)
For c = 1 To UBound(k, 2)
d(r + x - 1, c) = k(r, c)
Next
Next
For c = 2 To UBound(d, 2): d(x - 1, c) = Hdr(1, c - 1): Next
End If
Else
Set Rng2 = Sheets("SCORE").Range("c3:m" & lRow + 9)
d = Rng2.Value2
For r = 1 To UBound(k, 1)
For c = 1 To UBound(k, 2)
d(UBound(d, 1) - UBound(k, 1) + r, c) = k(r, c)
Next
Next
For c = 2 To UBound(d, 2): d(UBound(d, 1) - UBound(k, 1), c) = Hdr(1, c - 1): Next
End If
Rng2 = d
Rng2.Columns(1).NumberFormat = "m/d/yyyy"
With Rng2.Resize(Rng2.Rows.Count + 2, Rng2.Columns.Count)
.Rows.RowHeight = 25
End With
On Error Resume Next
Set nmFlag = ThisWorkbook.Names("Flag")
On Error GoTo 0
If nmFlag Is Nothing Then
ThisWorkbook.Names.Add "Flag", "TRUE", 1
Else
nmFlag.RefersTo = "TRUE"
End If
'transfer code ends here. So put the msgbox here.
MsgBox "Data has been Transferred to Score sheet", vbInformation
Else
MsgBox "Cannot transfer until all data entered", vbCritical
End If

End Sub

[rich_cirillo]

Thank you