VBA Code To Move Data From One Sheet To Another And Delete From Source Sheet

**rich_cirillo** · 06-20-2013, 11:22 AM

**rich_cirillo** · 06-21-2013, 01:31 AM

Updated

Hi

I require a macro to enter data..I enter data into Sheet 1 for each day.When i have all 5 days of data filled i press a button (macro) and it inserts the data into Sheet 2 matching the dates in Sheet 2 (sheet 1 and Sheet 2 dates must be an exact match to enter).....it enters the names,numbers and average,,Sheet 1 data will go into Sheet 2 cells C5:N10,,,,,,i also need a button to delete the names,numbers and average from sheet 1 once entered in Sheet 2.....is it possible that the data cannot be deleted from Sheet 1 unless it has been entered in Sheet 2....

When i change the date in Sheet 1 B2 to the 1/7/2013 again when all the data is entered i then press the macro button and it enters the data into the 1/7/2013 to 5/7/2013 range (C12:N17)

Once the data is entered into Sheet 2 it is permanent....

Thanks

Rich

**rich_cirillo** · 06-22-2013, 01:42 PM

If code is not possible maybe a formula would work..

**Admin** · 06-22-2013, 02:41 PM

Hi

Try this.

Code:

Option Explicit

Sub kTest()
    
    Dim d, i As Long, k, q, x, r As Long
    Dim c As Long, lRow As Long, Rng As Range
    
    lRow = Sheet2.Range("b" & Sheet2.Rows.Count).End(3).Row
    Set Rng = Sheet2.Range("b5:n" & lRow)
    d = Rng.Value2
    q = Application.Index(d, 0, 1)
    k = Sheet1.Range("b6:n11").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
        End If
    Else
        Set Rng = Sheet2.Range("b5:n" & lRow + 7)
        d = Rng.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
    End If
    Rng = d
    Rng.Columns(1).NumberFormat = "m/d/yyyy"
    Sheet1.Range("c6:n10").ClearContents
    
End Sub

**rich_cirillo** · 06-22-2013, 03:33 PM

Hi Admin
Impressive. Thank you and the code works exactly how I hoped it would
May I please finish this off with a couple of changes

I have changed the range slightly.Can the code copy the yellow cells (Sheet 1 C21:L21) into the cell range in Sheet 2 which is D3:M3 , D12:M12 , D21:M21 etc..etc..down to row 300 and the other cells copies as you programmed with dates matching

Can the button "transfer data to sheet 2" only be allowed to transfer data to sheet 2 if all 5 days have data entered

Can the button "clear data" be included in the code,Can the data only be cleared if the data has been transferred to sheet 2

Thanks for all your time

Rich

**Admin** · 06-22-2013, 07:32 PM

Hi

Try this. Assign these macro to corresponding buttons.

Code:

Option Explicit

Sub kTest()
    
    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 = Sheet2.Range("c" & Sheet2.Rows.Count).End(3).Row
    Set Rng2 = Sheet2.Range("c3:m" & lRow)
    d = Rng2.Value2
    q = Application.Index(d, 0, 1)
    
    Set Rng1 = Sheet1.Range("b32:l37")
    Hdr = Sheet1.Range("c21:l21")
    
    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 = Sheet2.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)
            .BorderAround , xlThin
            .Borders(xlInsideHorizontal).Weight = xlThin
            .Borders(xlInsideVertical).Weight = xlThin
            .Rows.RowHeight = 25
        End With
    End If
    
End Sub

Sub ClearData()
        
    Sheet1.Range("b32:l36").ClearContents
    
End Sub

**rich_cirillo** · 06-23-2013, 01:15 PM

Hi Admin

Thanks.Works excellent

Could you please make a final alteration

1. If all data is not entered in Sheet 1 C32:L36 ( all 5 days must have data) and the button "Transfer to Sheet 2" is pressed then it displays a message "cannot transfer until all data entered"

2. The data in Sheet 1 C32:L36 cannot be deleted unless it has been transferred to Sheet 2.....eg if only 3 days have data and the button "clear data" is pressed then a warning message says "cannot be deleted as incomplete"...the data will not be cleared...

Thanks again

Rich

**Admin** · 06-23-2013, 04:01 PM

Try

Code:

Option Explicit

Sub kTest()
    
    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 = Sheet2.Range("c" & Sheet2.Rows.Count).End(3).Row
    Set Rng2 = Sheet2.Range("c3:m" & lRow)
    d = Rng2.Value2
    q = Application.Index(d, 0, 1)
    
    Set Rng1 = Sheet1.Range("b32:l37")
    Hdr = Sheet1.Range("c21:l21")
    
    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 = Sheet2.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)
            .BorderAround , xlThin
            .Borders(xlInsideHorizontal).Weight = xlThin
            .Borders(xlInsideVertical).Weight = xlThin
            .Rows.RowHeight = 25
        End With
    Else
        MsgBox "Cannot transfer until all data entered", vbCritical
    End If
    
End Sub

Sub ClearData()
    
    Dim Rng     As Range
        
    Set Rng = Sheet1.Range("b32:l37")
    
    If Application.WorksheetFunction.CountA(Rng) = Rng.Cells.Count Then
        Sheet1.Range("b32:l36").ClearContents
    Else
        MsgBox "Cannot be deleted as incomplete", vbCritical
    End If
    
End Sub

**rich_cirillo** · 06-23-2013, 04:15 PM

Hi Admin
Excellent.Thank you as the VBA works as asked for..

Just curious but would a formula have been able to get the data to enter into Sheet2 from Sheet1.....say when data is entered into sheet1 17/6/2013 then it enters that data into Sheet2 for the 17/6/2013.....when data is entered in Sheet1 for 18/6/2013 then it also enters into Sheet2 for the 18/6/2013 and so on....The names in yellow are on;y changed once a week on a Monday...just curious

Thanks again for your help

Rich

**rich_cirillo** · 06-23-2013, 04:24 PM

Hi Admin

Can the following be altered

I added all the data in Sheet 1 and before I pressed the button "transfer to sheet 2" I hit the "Clear Data" button and it deleted the data before I transferred it to Sheet 2....can the Clear Data button only clear data if the data has been transferred to Sheet 2 first...can a message "Transfer data to sheet 2"