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




Reply With Quote
Bookmarks