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: 15
  • Data.png
    Data.png
    72.9 KB · Views: 15

Excel Facts

Add Bullets to Range
Select range. Press Ctrl+1. On Number tab, choose Custom. Type Alt+7 then space then @ sign (using 7 on numeric keypad)
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
201
qplsn9
Q
excelbytes
  • Solved
VBA Code To Copy Data Into Next Blank Column
Replies
5
Views
70
mumps
mumps
H
  • Question
VBA Speed up Copy and paste
Replies
3
Views
367
skillilea
S
D
  • Question
VBA for Copying & pasting (with resizing) Named ranges from one workbook to another
Replies
3
Views
545
doctorhifi
D
willow1985
  • Solved
Find first blank cell in column A in a Table - Runtime error 91
Replies
4
Views
96
willow1985
willow1985

Forum statistics

Threads
1,214,798
Messages
6,121,630
Members
449,041
Latest member
Postman24

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