Limit columns copied to another sheet and combine modules

smr108

New Member
Joined
Dec 27, 2020
Messages
6
Office Version
  1. 365
Platform
  1. Windows
I have looked on the internet to learn how to write something to copy data from one sheet to another based on values in a column. I have created 3 modules to do that. One of them is below. Each time it overwrites everything in the destination sheet. Is there a way to limit the columns that get copied into the destination sheet? I also run each module as a macro but would like to combine all of them and run them at the same time. Is that possible?

VBA Code:
Sub CopyEarn()
    Dim c As Range
    Dim j As Integer
    Dim Source As Worksheet
    Dim Target As Worksheet

    ' Change worksheet designations as needed
    Set Source = ActiveWorkbook.Worksheets("Transactions")
    Set Target = ActiveWorkbook.Worksheets("Earn")

    j = 1     ' Start copying to row 1 in target sheet
    For Each c In Source.Range("B2:B1000")   ' Do 1000 rows
        If c = "Coinbase Earn" Then
           Source.Rows(c.Row).copy Target.Rows(j)
           j = j + 1
        End If
    Next c
End Sub
 

Some videos you may like

Excel Facts

Wildcard in VLOOKUP
Use =VLOOKUP("Apple*" to find apple, Apple, or applesauce

rollis13

Active Member
Joined
Jul 30, 2012
Messages
371
Office Version
  1. 2016
Platform
  1. Windows
Try changing this line of code from:
Source.Rows(c.Row).copy Target.Rows(j)
to:
Source.Range("A" & c.Row).Resize(, 6).Copy Target.Range("A" & j)
and update this part of it:
.Resize(, 6)
to suit num. of columns to copy.

What are the other modules supposed to do ? in what do they differ, this line maybe ? (If c = "Coinbase Earn" Then)
 

smr108

New Member
Joined
Dec 27, 2020
Messages
6
Office Version
  1. 365
Platform
  1. Windows
Thank you for the response! This worked perfectly! All the modules do the same thing based on the line you identified. The others are look for Rewards, Convert, Buy , Send. It would be nice to have them run together. I'm new at this but I think they could be combined.
 

rollis13

Active Member
Joined
Jul 30, 2012
Messages
371
Office Version
  1. 2016
Platform
  1. Windows
See if I didn't mess up everything. I added and changed some lines of code.
VBA Code:
Option Explicit
Sub CopyEarn()
    Dim c      As Range
    Dim j      As Integer
    Dim Source As Worksheet
    Dim Target As Worksheet
    Dim srch   As Variant                         '<= added
    ' Change worksheet designations as needed
    Set Source = ActiveWorkbook.Worksheets("Transactions")
    Set Target = ActiveWorkbook.Worksheets("Earn")
    j = 1                                         ' Start copying to row 1 in target sheet
    For Each c In Source.Range("B2:B1000")        ' Do 1000 rows
        For Each srch In Array("Coinbase Earn", "Rewards", "Convert", "Buy") '<= added
            If c.Value Like srch Then             '<= changed
                'Source.Rows(c.Row).copy Target.Rows(j)
                Source.Range("A" & c.Row).Resize(, 12).Copy Target.Range("A" & j) '<= change .Risize(, 6) to suit num. of columns to copy
                j = j + 1
            End If
        Next srch                                 '<= added
    Next c
End Sub
 

smr108

New Member
Joined
Dec 27, 2020
Messages
6
Office Version
  1. 365
Platform
  1. Windows

ADVERTISEMENT

The code runs very well. However, it copies everything into the Earn sheet vs copying the Buy transactions into the Buy Sheet and Send transactions to the Send sheet for example.
 

rollis13

Active Member
Joined
Jul 30, 2012
Messages
371
Office Version
  1. 2016
Platform
  1. Windows
Now the macro works with separate Target sheets.
I also have chosen to process only the used rows in Source sheet. Since I have no idea how your data is organized, it's up to you decide which is the best choice.
VBA Code:
Option Explicit
Sub CopyEarn()
    Dim c      As Range
    Dim j      As Long
    Dim Source As Worksheet
    Dim Target As Worksheet
    Dim srch   As Variant
    Set Source = ActiveWorkbook.Worksheets("Transactions")
    'For Each c In Source.Range("B2:B1000")        'Do 1000 rows
    For Each c In Source.Range("B2:B" & Source.Range("B2").End(xlDown).Row) '<= Does only used rows
        For Each srch In Array("Coinbase Earn", "Rewards", "Convert", "Buy")
            If c Like srch Then
                With ActiveWorkbook.Worksheets(srch)
                    j = .Range("A" & .Rows.Count).End(xlUp).Row + 1
                    Source.Range("A" & c.Row).Resize(, 12).Copy .Range("A" & j)
                End With
            End If
        Next srch
    Next c
End Sub
 
Solution

smr108

New Member
Joined
Dec 27, 2020
Messages
6
Office Version
  1. 365
Platform
  1. Windows

ADVERTISEMENT

Thank you!!!
 

rollis13

Active Member
Joined
Jul 30, 2012
Messages
371
Office Version
  1. 2016
Platform
  1. Windows
Glad having been of some help(y).
Maybe adding this line would be even better:
Code:
[...]
j = .Range("A" & .Rows.Count).End(xlUp).Row
If .Range("A1") <> "" Then j = j + 1  '= added
Source.Range("A" & c.Row).Resize(, 12).Copy .Range("A" & j)
[...]
 
Last edited:

rollis13

Active Member
Joined
Jul 30, 2012
Messages
371
Office Version
  1. 2016
Platform
  1. Windows
There is a typo in post #6. Didn't wake up well this morning but now I made up my mind:
To begin pasting from row 2 in target sheets use:
VBA Code:
[...]
j = .Range("A" & .Rows.Count).End(xlUp).Row
Source.Range("A" & c.Row).Resize(, 12).Copy .Range("A" & j + 1)   '<= fixed
[...]
instead to start from row 1 use:
Code:
[...]
j = .Range("A" & .Rows.Count).End(xlUp).Row
If .Range("A1") <> "" Then j = j + 1    '<= added
Source.Range("A" & c.Row).Resize(, 12).Copy .Range("A" & j)
[...]
 

smr108

New Member
Joined
Dec 27, 2020
Messages
6
Office Version
  1. 365
Platform
  1. Windows
This revision loads all the sheets except the Buy sheet. In that sheet it only loads column 1.
 

Attachments

  • Screenshot 2020-12-28 102839.png
    Screenshot 2020-12-28 102839.png
    19.2 KB · Views: 0

Watch MrExcel Video

Forum statistics

Threads
1,123,281
Messages
5,600,715
Members
414,401
Latest member
grenona2020

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
Top