Automate Copying Specific Cells from One Worksheet to Specific Cells in another Worksheet's Next Empty Row

R

rodl66

New Member
Joined
Mar 8, 2023
Messages
26
Office Version
  1. 365
Platform
  1. Windows
I am using Excel 365, and have a workbook with several worksheets. I am trying to get the data that is typed into my "EntryChecklist" unlocked cells into the next empty row on the
"Data" ws. I currently have a button to do this, but ideally, I'd like for the data that is being entered into the cells on the "EntryChecklist" ws to concurrently be input into the
respective cells of the "Data" ws.

The code I have throws a Run-time error '1004' Method 'Range' of object'_Worksheet' failed when I click the button. I am still new to VBA and am struggling to fix the error. Here's what I have:

Sub CopyEntryCL()

' Get the correct worksheet

Dim shRead As Worksheet
Dim shWrite As Worksheet
Dim FirstEmptyRow As Long
Set shRead = ThisWorkbook.Worksheets("EntryChecklist")
Set shWrite = ThisWorkbook.Worksheets("Data")

' selects the next empty row
' ignores blanks inbetween the data set

Range("A" & Rows.Count).End(xlUp).Offset(1).Select


' Copy data from cell B3 on the EntryChecklist worksheet to cell D of the first empty row in the Data worksheet
shRead.Range("B3").Copy
shWrite.Range("D").PasteSpecial xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=True

' Copy data from cell D3 on the EntryChecklist worksheet to cell F of the empty row in the Data worksheet
shRead.Range("D3").Copy
shWrite.Range("F").PasteSpecial xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=True

' Copy data from cell F3 on the EntryChecklist worksheet to cell A of the empty row in the Data worksheet
shRead.Range("F3").Copy
shWrite.Range("A").PasteSpecial xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=True

' Copy data from cell B6 on the EntryChecklist worksheet to cell G of the empty row in the Data worksheet
shRead.Range("B6").Copy
shWrite.Range("G").PasteSpecial xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=True

' Copy data from cell D6 on the EntryChecklist worksheet to cell I of the empty row in the Data worksheet
shRead.Range("D6").Copy
shWrite.Range("I").PasteSpecial xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=True

' Copy data from cell F6 on the EntryChecklist worksheet to cell B of the empty row in the Data worksheet
shRead.Range("F6").Copy
shWrite.Range("B").PasteSpecial xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=True

' Copy data from cell B9 on the EntryChecklist worksheet to cell J of the empty row in the Data worksheet
shRead.Range("B9").Copy
shWrite.Range("J").PasteSpecial xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=True

' Copy data from cell D9 on the EntryChecklist worksheet to cell L of the empty row in the Data worksheet
shRead.Range("D9").Copy
shWrite.Range("L").PasteSpecial xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=True

' Copy data from cell F9 on the EntryChecklist worksheet to cell C of the empty row in the Data worksheet
shRead.Range("F9").Copy
shWrite.Range("FC").PasteSpecial xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=True

' Copy data from cell B24 on the EntryChecklist worksheet to cell Mof the empty row in the Data worksheet
shRead.Range("B24").Copy
shWrite.Range("M").PasteSpecial xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=True

' Copy data from cell D24 on the EntryChecklist worksheet to cell N of the empty row in the Data worksheet
shRead.Range("D24").Copy
shWrite.Range("N").PasteSpecial xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=True

' Copy data from cell B30 on the EntryChecklist worksheet to cell O of the empty row in the Data worksheet
shRead.Range("B30").Copy
shWrite.Range("O").PasteSpecial xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=True

' Copy data from cell B33 on the EntryChecklist worksheet to cell P of the empty row in the Data worksheet
shRead.Range("B33").Copy
shWrite.Range("P").PasteSpecial xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=True

' Copy data from cell D30 on the EntryChecklist worksheet to cell Q of the empty row in the Data worksheet
shRead.Range("D30").Copy
shWrite.Range("Q").PasteSpecial xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=True

' Copy data from cell F29 on the EntryChecklist worksheet to cell R of the empty row in the Data worksheet
shRead.Range("F29").Copy
shWrite.Range("R").PasteSpecial xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=True

' Copy data from cell F31 on the EntryChecklist worksheet to cell S of the empty row in the Data worksheet
shRead.Range("F31").Copy
shWrite.Range("S").PasteSpecial xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=True


End Sub

I am sure there is also a cleaner way to do this. I've included screen shots of my two worksheets as well.

Thank you in advance!
 

Attachments

  • EntryChecklist.png
    EntryChecklist.png
    189.6 KB · Views: 20
  • Data.png
    Data.png
    72.9 KB · Views: 19

Excel Facts

Copy formula down without changing references
If you have =SUM(F2:F49) in F50; type Alt+' in F51 to copy =SUM(F2:F49) to F51, leaving the formula in edit mode. Change SUM to COUNT.
Sort by date Sort by votes
Copy and paste this macro into the worksheet code module. Do the following: right click the tab name for your "EntryChecklist" sheet and click 'View Code'. Paste the macro into the empty code window that opens up. Close the code window to return to your sheet. Enter a value in your unlocked cells and press the ENTER key.
VBA Code: 
Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.CountLarge > 1 Then Exit Sub
    If Intersect(Target, Range("B3,D3,F3,B6,D6,F6,B9,D9,F9,B24,D24,B30,B33,D30,F29,F31")) Is Nothing Then Exit Sub
    Application.ScreenUpdating = False
    Dim shWrite As Worksheet
    Set shWrite = ThisWorkbook.Worksheets("Data")
    With shWrite
        Select Case Target.Address(0, 0)
            Case "B3"
                .Cells(.Rows.Count, "D").End(xlUp).Offset(1) = Target
            Case "D3"
                .Cells(.Rows.Count, "F").End(xlUp).Offset(1) = Target
            Case "F3"
                .Cells(.Rows.Count, "A").End(xlUp).Offset(1) = Target
            Case "B6"
                .Cells(.Rows.Count, "G").End(xlUp).Offset(1) = Target
            Case "D6"
                .Cells(.Rows.Count, "I").End(xlUp).Offset(1) = Target
            Case "F6"
                .Cells(.Rows.Count, "B").End(xlUp).Offset(1) = Target
            Case "B9"
                .Cells(.Rows.Count, "J").End(xlUp).Offset(1) = Target
            Case "D9"
                .Cells(.Rows.Count, "L").End(xlUp).Offset(1) = Target
            Case "F9"
                .Cells(.Rows.Count, "C").End(xlUp).Offset(1) = Target
            Case "B24"
                .Cells(.Rows.Count, "M").End(xlUp).Offset(1) = Target
            Case "D24"
                .Cells(.Rows.Count, "N").End(xlUp).Offset(1) = Target
            Case "B30"
                .Cells(.Rows.Count, "0").End(xlUp).Offset(1) = Target
            Case "B33"
                .Cells(.Rows.Count, "P").End(xlUp).Offset(1) = Target
            Case "D30"
                .Cells(.Rows.Count, "Q").End(xlUp).Offset(1) = Target
            Case "F29"
                .Cells(.Rows.Count, "R").End(xlUp).Offset(1) = Target
            Case "F31"
                .Cells(.Rows.Count, "S").End(xlUp).Offset(1) = Target
        End Select
    End With
    Application.ScreenUpdating = True
End Sub
 
Upvote 0
Solution
mumps said:
Copy and paste this macro into the worksheet code module. Do the following: right click the tab name for your "EntryChecklist" sheet and click 'View Code'. Paste the macro into the empty code window that opens up. Close the code window to return to your sheet. Enter a value in your unlocked cells and press the ENTER key.
VBA Code: 
Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.CountLarge > 1 Then Exit Sub
    If Intersect(Target, Range("B3,D3,F3,B6,D6,F6,B9,D9,F9,B24,D24,B30,B33,D30,F29,F31")) Is Nothing Then Exit Sub
    Application.ScreenUpdating = False
    Dim shWrite As Worksheet
    Set shWrite = ThisWorkbook.Worksheets("Data")
    With shWrite
        Select Case Target.Address(0, 0)
            Case "B3"
                .Cells(.Rows.Count, "D").End(xlUp).Offset(1) = Target
            Case "D3"
                .Cells(.Rows.Count, "F").End(xlUp).Offset(1) = Target
            Case "F3"
                .Cells(.Rows.Count, "A").End(xlUp).Offset(1) = Target
            Case "B6"
                .Cells(.Rows.Count, "G").End(xlUp).Offset(1) = Target
            Case "D6"
                .Cells(.Rows.Count, "I").End(xlUp).Offset(1) = Target
            Case "F6"
                .Cells(.Rows.Count, "B").End(xlUp).Offset(1) = Target
            Case "B9"
                .Cells(.Rows.Count, "J").End(xlUp).Offset(1) = Target
            Case "D9"
                .Cells(.Rows.Count, "L").End(xlUp).Offset(1) = Target
            Case "F9"
                .Cells(.Rows.Count, "C").End(xlUp).Offset(1) = Target
            Case "B24"
                .Cells(.Rows.Count, "M").End(xlUp).Offset(1) = Target
            Case "D24"
                .Cells(.Rows.Count, "N").End(xlUp).Offset(1) = Target
            Case "B30"
                .Cells(.Rows.Count, "0").End(xlUp).Offset(1) = Target
            Case "B33"
                .Cells(.Rows.Count, "P").End(xlUp).Offset(1) = Target
            Case "D30"
                .Cells(.Rows.Count, "Q").End(xlUp).Offset(1) = Target
            Case "F29"
                .Cells(.Rows.Count, "R").End(xlUp).Offset(1) = Target
            Case "F31"
                .Cells(.Rows.Count, "S").End(xlUp).Offset(1) = Target
        End Select
    End With
    Application.ScreenUpdating = True
End Sub
Click to expand...
mumps - thank you very much, this worked like a charm.
 
Upvote 0
You must log in or register to reply here.

Similar threads

Q
  • Solved
How to stop InputBox from looping after input?
Replies
7
Views
479
qplsn9
Q
S
  • Question Question
Dynamic Address by VBA
Replies
8
Views
151
MikeVol
MikeVol
N
  • Question Question
Excel VBA copy data to a worksheet in list form
Replies
0
Views
92
NewbieExcel123
N
K
  • Question Question
Increasing row before the macro runs again
Replies
1
Views
211
kbk
K
brent3162
  • Solved
VBA help with increasing row before macro runs again.
Replies
3
Views
363
jolivanes
jolivanes

Forum statistics

Threads
1,223,885
Messages
6,175,187
Members
452,616
Latest member
intern444

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top