Vba copy paste

[kiwi101]

Hey guys

Im trying to copy some columns from one sheet and paste it onto another. I've come up with a code. Its supposed to copy items of 2 columns from the first worksheet which are "Profile" and "Email Address" and paste it onto the second worksheet on columns "ID"(Column 9 in Excel) and "Email Address"(Column 8 in Excel).
However it is only copying content of column "Profile" and pasting it twice on the second worksheet under "ID" and "Email Address" Can anyone see what I am doing wrong?
[/
Sub example()




Dim RoleWkb As Workbook, figWkb As Workbook, RoleWkst As Worksheet, figWkst As Worksheet


Set RoleWkb = Workbooks.Open("C:\Users\jjjj.xlsm")
Set figWkb = ThisWorkbook
Set RoleWkst = RoleWkb.Sheets("Profile")
Set figWkst = ConfigWkb.Worksheets("Information")


Dim cgroup As Range, cgroupstart As Range, cgroupend As Range
Dim ugroup As Range, ugroupstart As Range, ugroupend As Range
Dim name As Range



'***grabs procurement agents from workbook and copies
With figWkst
Set cgroup = .Columns(9).Find(What:="ID")
If Not cgroup Is Nothing Then
Set cgroupstart = cgroup.Offset(1)
Set cgroupend = Range(cgroupstart, cgroupstart.End(xlDown))
'if there are more than users
If WorksheetFunction.CountA(cgroupend) > 1 Then
cgroupend.Copy
'else (only one user)
Else: cgroupstart.Copy
End If
End If
End With

'pastes procurement agents to user role
With RoleWkst
Set ugroup = .Columns(1).Find(What:="User")
If Not ugroup Is Nothing Then
Set ugroupstart = ugroup.Offset(1, 0)
ugroupstart.PasteSpecial xlPasteValues
Set ugroupend = Range(ugroupstart, ugroupstart.End(xlDown))
If WorksheetFunction.CountA(ugroupend) > 2 Then
Else: Set ugroupend = Range(ugroupstart, ugroupstart.Offset(1))
End If
End If

End With


With figWkst
Set cgroup = .Columns(8).Find(What:="Email Address")
If Not cgroup Is Nothing Then
Set cgroupstart = cgroup.Offset(1, 1)
Set cgroupend = Range(cgroupstart, cgroupstart.End(xlDown))
If WorksheetFunction.CountA(cgroupend) > 1 Then
cgroupend.Copy
Else: cgroupstart.Copy
End If
End If
End With

'pastes cos USERID and e-mail
With RoleWkst
Set ugroup = .Columns(8).Find(What:="Email Address")
If Not ugroup Is Nothing Then
Set ugroupstart = ugroup.Offset(2, 2)
ugroupstart.PasteSpecial xlPasteValues
Set ugroupstart = ugroup.Offset(2, 4)
ugroupstart.PasteSpecial xlPasteValues
If WorksheetFunction.CountA(ugroupstart) > 1 Then
Set ugroupend = Range(ugroupstart, ugroupstart.End(xlDown))
Else: Set ugroupend = Range(ugroupstart, ugroupstart.Offset(1))
End If
End If
End With










End Sub
/]

 

[JLGWhiz]

This is not fully tested but it should work. Try it and post back with prolems.

Sub example2()
 Dim RoleWkb As Workbook, figWkb As Workbook, RoleWkst As Worksheet, figWkst As Worksheet
 Dim cgroup As Range
 Dim ugroup As Range
 Set RoleWkb = Workbooks.Open("C:\Users\jjjj.xlsm")
 Set figWkb = ThisWorkbook
 Set RoleWkst = RoleWkb.Sheets("Profile")
 Set figWkst = ConfigWkb.Worksheets("Information")
 With figWkst
    Set cgroup = .Columns(9).Find(What:="ID")
    If Not cgroup Is Nothing Then
        .Range(cgroup.Offset(1), .Cells(Rows.Count, cgroup.Column).End(xlUp)).Copy
    End If
    Set cgroup = Nothing
 End With
 With RoleWkst
    On Error Resume Next
    .Columns(1).Find(What:="User").Offset(1).PasteSpecial xlPasteValues
    On Error GoTo 0
 End With
 With figWkst
    Set cgroup = .Columns(8).Find(What:="Email Address")
    If Not cgroup Is Nothing Then
        .Range(cgroup.Offset(1), .Cells(Rows.Count, cgroup.Column).End(xlUp)).Copy
    End If
    Set cgroup = Nothing
 End With
 With RoleWkst
    On Error Resume Next
    .Columns(8).Find(What:="Email Address").Offset(2, 2).PasteSpecial xlPasteValues
    On Error GoTo 0
 End With
End Sub

 

[kiwi101]

Hello
Thank you the code works
1. Can you please explain what you changed and logic? Because I will have to post a couple more columns and I would like to understand

2. Even though I have mentioned in the code for it to paste the Email Address in Column 8 of sheet 2 it is posting it in Column 2 right next to the first paste. Do you know why? And how I can fix this?

    .Columns(8).Find(What:="Email Address").Offset(2, 2).PasteSpecial xlPasteValues

 

[kiwi101]

Nevermind I've corrected the offset and it pastes perfectly fine.
However I had a question. From the first worksheet: there are 2 columns City and Country
I am trying to merge them onto Second worksheet as one column named Address.This is the code I am stuck on:
[/code]
With figWkst Set cgroup = .Columns(6).Find(What:="City")
If Not cgroup Is Nothing Then
.Range(cgroup.Offset(1), .Cells(Rows.Count, cgroup.Column).End(xlUp)).Copy
End If
Set cgroup = Nothing
End With


With figWkst
Set cgroup = .Columns(7).Find(What:="Country")
If Not cgroup Is Nothing Then
.Range(cgroup.Offset(1), .Cells(Rows.Count, cgroup.Column).End(xlUp)).Copy
End If
Set cgroup = Nothing
End With

With RoleWkst
On Error Resume Next
.Columns(2).Find(What:="Address").Offset(1).PasteSpecial xlPasteValues
On Error GoTo 0
End With

Range("Address").Cell.Value = Range("City").Cell.Value & Range("Country").Cell.Value

[\code]

 

[JLGWhiz]

Nevermind I've corrected the offset and it pastes perfectly fine.
However I had a question. From the first worksheet: there are 2 columns City and Country
I am trying to merge them onto Second worksheet as one column named Address.This is the code I am stuck on:
[/code]
With figWkst Set cgroup = .Columns(6).Find(What:="City")
If Not cgroup Is Nothing Then
.Range(cgroup.Offset(1), .Cells(Rows.Count, cgroup.Column).End(xlUp)).Copy
End If
Set cgroup = Nothing
End With
'Where is the paste command?

With figWkst
Set cgroup = .Columns(7).Find(What:="Country")
If Not cgroup Is Nothing Then
.Range(cgroup.Offset(1), .Cells(Rows.Count, cgroup.Column).End(xlUp)).Copy
End If
Set cgroup = Nothing
End With

With RoleWkst
On Error Resume Next
.Columns(2).Find(What:="Address").Offset(1).PasteSpecial xlPasteValues
On Error GoTo 0
End With

Range("Address").Cell.Value = Range("City").Cell.Value & Range("Country").Cell.Value

[\code]

This will only paste the second copy range. The code does not execute a paste action for the first copy.

 

[kiwi101]

Ok so based on that:
I am copying/pasting for the first time and then copying and then pasting with a space for the second time.

 [COLOR=#333333][I]With figWkst Set cgroup = .Columns(6).Find(What:="City")[/I][/COLOR]
[COLOR=#333333][I]If Not cgroup Is Nothing Then[/I][/COLOR]
[COLOR=#333333][I].Range(cgroup.Offset(1), .Cells(Rows.Count, cgroup.Column).End(xlUp)).Copy[/I][/COLOR]
[COLOR=#333333][I]End If[/I][/COLOR]
[COLOR=#333333][I]Set cgroup = Nothing[/I][/COLOR]
[COLOR=#333333][I]End With

[/I][/COLOR][COLOR=#333333][I]With RoleWkst[/I][/COLOR]
[COLOR=#333333][I]On Error Resume Next[/I][/COLOR]
[COLOR=#333333][I].Columns(2).Find(What:="Address").Offset(1).PasteSpecial xlPasteValues[/I][/COLOR]
[COLOR=#333333][I]On Error GoTo 0[/I][/COLOR]
[COLOR=#333333][I]End With[/I][/COLOR]
[COLOR=#ff0000][/COLOR]
[COLOR=#333333][I]With figWkst[/I][/COLOR]
[COLOR=#333333][I]Set cgroup = .Columns(7).Find(What:="Country")[/I][/COLOR]
[COLOR=#333333][I]If Not cgroup Is Nothing Then[/I][/COLOR]
[COLOR=#333333][I].Range(cgroup.Offset(1), .Cells(Rows.Count, cgroup.Column).End(xlUp)).Copy[/I][/COLOR]
[COLOR=#333333][I]End If[/I][/COLOR]
[COLOR=#333333][I]Set cgroup = Nothing[/I][/COLOR]
[COLOR=#333333][I]End With[/I][/COLOR]

[COLOR=#333333][I]With RoleWkst[/I][/COLOR]
[COLOR=#333333][I]On Error Resume Next[/I][/COLOR]
[COLOR=#333333][I].Columns(2).Find(What:="Address").Offset(1).Space(1).PasteSpecial xlPasteValues[/I][/COLOR]
[COLOR=#333333][I]On Error GoTo 0[/I][/COLOR]
[COLOR=#333333][I]End With

[/I]
How can I make it recognize the first item that was there so it just simply adds a space and pastes second item. I feel Im on the right track.[/COLOR]

 

[JLGWhiz]

Change This

.Columns(2).Find(What:="Address").Offset(1).PasteSpecial xlPasteValues

to this

.Cells(Rows.Count, 2).End(xlUp)([COLOR=#b22222]3[/COLOR]).PasteSpecial xlPasteValues

The red 3 determines the row offset from the last row with data in that column for the paste range. With the 3 you get one empty row. The offset with this method is always one less than the integer used.

 

[kiwi101]

Hi
Ive made the replacement you mentioned and its only copy/pasting "City" cell and not adding "Country"

 With figWkst Set cgroup = .Columns(6).Find(What:="City")
If Not cgroup Is Nothing Then
.Range(cgroup.Offset(1), .Cells(Rows.Count, cgroup.Column).End(xlUp)).Copy
End If
Set cgroup = Nothing
End With

With RoleWkst
On Error Resume Next
.Cells(Rows.Count, 2).End(xlUp)(3).PasteSpecial xlPasteValues
On Error GoTo 0
End With

With figWkst
Set cgroup = .Columns(7).Find(What:="Country")
If Not cgroup Is Nothing Then
.Range(cgroup.Offset(1), .Cells(Rows.Count, cgroup.Column).End(xlUp)).Copy
End If
Set cgroup = Nothing
End With

With RoleWkst
On Error Resume Next
.Cells(Rows.Count, 2).End(xlUp)(3).Space(1).PasteSpecial xlPasteValues
On Error GoTo 0
End With 

The second red row I've tried with and without the ".Space(1)" but results are the same. It only copy/pastes City from sheet 1 into "Address" of sheet 2.
What its supposed to look like Address: City Country
What it looks like: Address: City

 

[JLGWhiz]

Hi
Ive made the replacement you mentioned and its only copy/pasting "City" cell and not adding "Country"

 With figWkst Set cgroup = .Columns(6).Find(What:="City")
If Not cgroup Is Nothing Then
.Range(cgroup.Offset(1), .Cells(Rows.Count, cgroup.Column).End(xlUp)).Copy
End If
Set cgroup = Nothing
End With

With RoleWkst
On Error Resume Next
.Cells(Rows.Count, 2).End(xlUp)(3).PasteSpecial xlPasteValues
On Error GoTo 0
End With

With figWkst
Set cgroup = .Columns(7).Find(What:="Country")
If Not cgroup Is Nothing Then
.Range(cgroup.Offset(1), .Cells(Rows.Count, cgroup.Column).End(xlUp)).Copy
End If
Set cgroup = Nothing
End With

With RoleWkst
On Error Resume Next
.Cells(Rows.Count, 2).End(xlUp)(3).Space(1).PasteSpecial xlPasteValues
On Error GoTo 0
End With 

The second red row I've tried with and without the ".Space(1)" but results are the same. It only copy/pastes City from sheet 1 into "Address" of sheet 2.
What its supposed to look like Address: City Country
What it looks like: Address: City

Remove the '.Space(1)'. I am surprised that you don't get an error from that. I don't see any other reason for it not to paste the values but I will take a closer look later. Have you tried stepping through the code using the F8 function key to see if you can detect where the code is either not copying or is not pasting?

 

[JLGWhiz]

I just ran this code in a test set up and it copied both ranges to the destination sheet putting one beneath the other with a one row separation.

Sub t()
 Dim RoleWkb As Workbook, figWkb As Workbook, RoleWkst As Worksheet, figWkst As Worksheet
 Dim cgroup As Range
 Dim ugroup As Range
 Set RoleWkb = Workbooks.Open("C:\Users\jjjj.xlsm")
 Set figWkb = ThisWorkbook
 Set RoleWkst = RoleWkb.Sheets("Profile")
 Set figWkst = figWkb.Worksheets("Information")
    With figWkst
        Set cgroup = .Columns(6).Find(What:="City")
        If Not cgroup Is Nothing Then
            .Range(cgroup.Offset(1), .Cells(Rows.Count, cgroup.Column).End(xlUp)).Copy
        End If
        Set cgroup = Nothing
    End With
    With RoleWkst
        On Error Resume Next
        .Cells(Rows.Count, 2).End(xlUp)(3).PasteSpecial xlPasteValues
        On Error GoTo 0
    End With
    With figWkst
        Set cgroup = .Columns(7).Find(What:="Country")
        If Not cgroup Is Nothing Then
            .Range(cgroup.Offset(1), .Cells(Rows.Count, cgroup.Column).End(xlUp)).Copy
        End If
        Set cgroup = Nothing
    End With
    With RoleWkst
        On Error Resume Next
        .Cells(Rows.Count, 2).End(xlUp)(3).PasteSpecial xlPasteValues
        On Error GoTo 0
    End With
End Sub

Check the workbook names in the declarations, I noticed a discrpancy while I was working with this. Configwbk v figwbk. Could be typo in the thread, but needs to be verified.