VBA code copy data from cell to another sheet in table

vpseuro

New Member
Joined
Sep 8, 2021
Messages
11
Office Version
  1. 2016
Platform
  1. Windows
Dear all,
I`m having trouble in creating a correct VBA code for a copy paste function.
Main sheet "home"
Second sheet "clients"

On "home" sheet i have 4 cells ( C column - "C4:C7") representing data: id nr, name from a dropdown, name entered manually , and a date.
This data should be copied in the second "clients" sheet in a table "clientstable" header starting on row 5, first table row should be 6.

i made progress but the paste entry goes to row 7 and not in the table,
second progress , data goes in the table but fills the entire table and not specific row by row as i need it.

the goal is that data should go from one cell C4 , c5 , c6 ,c7 home sheet to A6 B6 C6 D6 clients sheet in table clientstable to next row in line available

Rich (BB code):
Sub InsertNewclient()
'
' Newclient Macro
'
'
Dim countrow As Long
Dim countcol As Long
Dim i As Integer
 Dim CurrentSheet As Object


countrow = Sheets("Clients").UsedRange.Rows.Count
countcol = Sheets("Clients").UsedRange.Columns.Count

 
    Sheets("Home").Select 
    Range("C4:C7").Select
  
    Selection.Copy
    Sheets("Clients").Select

    Range("Clientstable").Select
  
    Cells(Rows.Count, 1).End(xlUp)(1).Select
    Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
        False, Transpose:=True
  
          
End Sub
 

Attachments

  • Screenshot 2021-09-09 045258.png
    Screenshot 2021-09-09 045258.png
    12.6 KB · Views: 65
  • clientstable abcd collums.png
    clientstable abcd collums.png
    9 KB · Views: 65
Hi, it does not seem to help,
on second sheet the row is added outside table in row 7, also if i trigger the macro again no new row is created
on third sheet The data goes to the tables,, except the 10 column were i have to dropdown manually and chose value also no new row created on next macro run
 
Upvote 0

Excel Facts

Excel Can Read to You
Customize Quick Access Toolbar. From All Commands, add Speak Cells or Speak Cells on Enter to QAT. Select cells. Press Speak Cells.
Try this:
VBA Code:
Sub AddData()
Dim Lr As Long, Ar1() As Variant, Ar2() As Variant, Lr2 As Long
Lr = Sheets("Clients").Range("A5").End(xlDown).Row - 1
Lr2 = Sheets("Clienttargetcollumn").Range("A6").End(xlDown).Row - 1
If Sheets("Clients").Range("A" & Lr) <> "" Then Lr = Lr + 2
If Sheets("Clienttargetcollumn").Range("A" & Lr2) <> "" Then Lr2 = Lr2 + 2
Ar1 = Application.Transpose(Sheets("Home").Range("C4:C7"))

Ar2 = Array(Ar1(1), Ar1(3), "", "", "", Ar1(4), "", "", "", Ar1(2))
Debug.Print Ar2(9)
Sheets("Clients").Range("A" & Lr & ":D" & Lr) = Ar1
Sheets("Clienttargetcollumn").Range("A" & Lr2).Resize(, UBound(Ar2) + 1) = Ar2
If Lr = Sheets("Clients").Range("A" & Rows.Count).End(xlUp).Row Then
Else
Sheets("Clients").ListObjects("ClientsTable").Resize Range("A5:D" & Lr)
End If
If Lr2 = Sheets("Clienttargetcollumn").Range("A6").End(xlDown).Row Then
Else
Debug.Print Sheets("Clienttargetcollumn").Range("A" & Rows.Count).End(xlUp).Row
Sheets("Clienttargetcollumn").ListObjects("Clienttargetcollumn").Resize Range("A6:J" & Lr2)
End If


End Sub
 
Upvote 0
Hi @maabadi

unfortunately it does not work,
and i actually need to macros for 2 buttons

Let`s first focus on the clients sheet and table Clients and build first macro for that. the topic is initially opened for copying data to one sheet with one macro, having in mind to adjust this one successful developed and implement it to copy data to the table Clientstargetcollum in second sheet.

i started with basic again by recording a macro. and this a successful code for adding data in to the table directly when table is completely empty.

maybe we can use it and adjust it with some IF Else so wen the macro is started to first check if data is available in the table if yes put data in next row same table.

VBA Code:
Sub Macro1()
'
' Macro1 Macro
'
    Range("C4:C7").Select
    Selection.Copy
    Sheets("Clients").Select
    Range("Clientstable[Order ID]").Select
   
    Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
        False, Transpose:=True
          

End Sub
 
Last edited:
Upvote 0
also after an if else check of the first row in the table an .insert data to new row should be performed
 
Upvote 0
also important the macro / buttons are triggered from Home sheet
 
Upvote 0
How you Create Buttons?
1. On Userform From VBA window?
2. With ActiveX Control from Developer Tab at Excel Window?
 
Upvote 0
At Developer Tab, enable Design Mode, Then Right-Click on Button and Select View Code, Then Paste this code after first Line ( Private Sub ... ):
VBA Code:
Dim Lr As Long, Ar1() As Variant, Ar2() As Variant, Lr2 As Long
On Error Resume Next
Lr = Sheets("Clients").Range("ClientsTable").Columns(1).Find(What:="", LookIn:=xlValues, LookAt:=xlWhole).Row
Lr2 = Sheets("Clients").ListObjects("ClientsTable").DataBodyRange.Row
If Lr2 > 0 And Lr <> Lr2 Then
If Sheets("Clients").Range("A" & Lr2) = "" Or Lr = 0 Then Lr = Sheets("Clients").Range("A" & Rows.Count).End(xlUp).Row + 1
End If
Ar1 = Application.Transpose(Sheets("Home").Range("C4:C7"))
Sheets("Clients").Range("A" & Lr & ":D" & Lr) = Ar1

Repeat above step for second button and Paste This:
VBA Code:
Dim Lr As Long, Ar1() As Variant, Ar2() As Variant, Lr2 As Long
On Error Resume Next
Lr = Sheets("Clienttargetcollumn").Range("Clienttargetcollumn").Columns(1).Find(What:="", LookIn:=xlValues, LookAt:=xlWhole).Row
Lr2 = Sheets("Clienttargetcollumn").ListObjects("Clienttargetcollumn").DataBodyRange.Row
If Lr2 > 0 And Lr <> Lr2 Then
If Sheets("Clienttargetcollumn").Range("A" & Lr2) = "" Or Lr = 0 Then Lr = Sheets("Clienttargetcollumn").Range("A" & Rows.Count).End(xlUp).Row + 1
End If
Ar1 = Application.Transpose(Sheets("Home").Range("C4:C7"))
Ar2 = Array(Ar1(1), Ar1(3), "", "", "", Ar1(4), "", "", "", Ar1(2))
Sheets("Clienttargetcollumn").Range("A" & Lr).Resize(, UBound(Ar2) + 1) = Ar2
 
Upvote 0
Solution
Dear @maabadi your solution did the work. Will implement it. I will also make a comment in the code referring to you, thank you.
 
Upvote 0

Forum statistics

Threads
1,214,822
Messages
6,121,772
Members
449,049
Latest member
greyangel23

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