VBA code message box added

**rich_cirillo** · 07-08-2013, 08:23 AM

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"....

Code:

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** · 07-08-2013, 09:03 AM

Hi

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

**rich_cirillo** · 07-08-2013, 09:10 AM

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

Thanks

**Admin** · 07-08-2013, 11:51 AM

Hi

Let me see your code (what you tried) ?

**rich_cirillo** · 07-08-2013, 04:31 PM

Here what I used...

Code:

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** · 07-08-2013, 04:57 PM

Hi

Code:

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