-
1 Attachment(s)
VBA Code To Move Data From One Sheet To Another And Delete From Source Sheet
-
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
-
If code is not possible maybe a formula would work..
-
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
-
1 Attachment(s)
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
-
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
-
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
-
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
-
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
-
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"
