PDA

View Full Version : Pasting range from Source ab to Destination tab based on name



Trials
02-07-2020, 07:09 AM
I have a source tab with three columns of data (Alpha, Beta, and Charlie) and each will be a range .
I am attempting to search through all tabs in my workbook and depending on the worksheet's name will paste one of these ranges to the end column "A" (each tab varies amount of rows).
Here's what I have so far.



Sub edit()
Dim ws As Worksheet
Dim data As Range
Dim units As Range

For Each ws In ActiveWorkbook.Worksheets
'Each sheet has different amount of rows in Column A where the data points are
'Search for sheets which contain Alpha
If ws.Name Like "Alpha-*" Then
Set ActiveSheet = ws
'copy range from the "Instructions" tab and paste it after the last row in destination tab
Worksheets("Instructions").Range("F3:F201").Copy _
Worksheets("ws.Name").Range("A5").End(xlDown).Offset(1, 0).Select

Set data = Worksheet.Range("F3:F201").Select
data.Copy

Set units = Range("A5").End(xlDown).Offset(1, 0).Select
units.PasteSpecial xlPasteValues
End If

'repeat with two more ranges searching for a specific tab names
'perhaps case select or another function would be more efficient?
If ws.Name Like "Beta-*" Then
Set ActiveSheet = ws
Worksheets("Instructions").Range("G3:G201").Copy _
Worksheets("ws.Name").Range("A5").End(xlDown).Offset(1, 0).Select

Set data = Worksheet.Range("G3:G201").Select
data.Copy

Set units = Range("A5").End(xlDown).Offset(1, 0).Select
units.PasteSpecial xlPasteValues
End If

If ws.Name Like "Charlie-*" Then
Set ActiveSheet = ws
Worksheets("Instructions").Range("H3:H201").Copy _
Worksheets("ws.Name").Range("A5").End(xlDown).Offset(1, 0).Select

Set data = Worksheet.Range("H3:H201").Select
data.Copy

Set units = Range("A5").End(xlDown).Offset(1, 0).Select
units.PasteSpecial xlPasteValues
End If

Next ws
End Sub


Please let me know if there is better selecting method. Also, here is the code I used to get started:

https://www.mrexcel.com/board/threads/if-worksheet-name-contains-vba.594090/
Thank you for any help.

p45cal
02-07-2020, 09:10 AM
Try the following noting any tweaks you might want to apply in the code (see comments in the code) by enabling/disabling some code lines:
Sub edit2()
Dim ws As Worksheet
Dim RngToCopy As Range, Destn As Range

For Each ws In ActiveWorkbook.Worksheets
Set RngToCopy = Nothing
Select Case True
Case ws.Name Like "Alpha-*"
Set RngToCopy = Worksheets("Instructions").Range("F3:F201")
Case ws.Name Like "Beta-*"
Set RngToCopy = Worksheets("Instructions").Range("G3:G201")
Case ws.Name Like "Charlie-*"
Set RngToCopy = Worksheets("Instructions").Range("H3:H201")
End Select
If Not RngToCopy Is Nothing Then
Set Destn = ws.Range("A5").End(xlDown).Offset(1) 'be aware there must be something below A5 for this to work. Also that if there are any blank cells among the data in column A this will find the first and overwrite any data below it.
'use only one of the following sections:

'Section 1: **********************************
' RngToCopy.Copy Destn 'copies everything: formulae, formats etc.
' Destn.Resize(RngToCopy.Rows.Count).Value = Destn.Resize(RngToCopy.Rows.Count).Value 'optional line to convert any formulae results to plain values.
'End Section 1 ********************************

'Section 2: **********************************
Destn.Resize(RngToCopy.Rows.Count).Value = RngToCopy.Value 'copies only values
'End Section 2 ********************************
End If
Next ws
End Sub

Trials
02-07-2020, 10:22 AM
Try the following noting any tweaks you might want to apply in the code (see comments in the code) by enabling/disabling some code lines:
Sub edit2()
Dim ws As Worksheet
Dim RngToCopy As Range, Destn As Range

For Each ws In ActiveWorkbook.Worksheets
Set RngToCopy = Nothing
Select Case True
Case ws.Name Like "Alpha-*"
Set RngToCopy = Worksheets("Instructions").Range("F3:F201")
Case ws.Name Like "Beta-*"
Set RngToCopy = Worksheets("Instructions").Range("G3:G201")
Case ws.Name Like "Charlie-*"
Set RngToCopy = Worksheets("Instructions").Range("H3:H201")
End Select
If Not RngToCopy Is Nothing Then
Set Destn = ws.Range("A5").End(xlDown).Offset(1) 'be aware there must be something below A5 for this to work. Also that if there are any blank cells among the data in column A this will find the first and overwrite any data below it.
'use only one of the following sections:

'Section 1: **********************************
' RngToCopy.Copy Destn 'copies everything: formulae, formats etc.
' Destn.Resize(RngToCopy.Rows.Count).Value = Destn.Resize(RngToCopy.Rows.Count).Value 'optional line to convert any formulae results to plain values.
'End Section 1 ********************************

'Section 2: **********************************
Destn.Resize(RngToCopy.Rows.Count).Value = RngToCopy.Value 'copies only values
'End Section 2 ********************************
End If
Next ws
End Sub


Thank you for the quick response. After stepping through yourcode, I’m seeing that the ws.Name is looping through each worksheet as the namechanges, but the RngToCopy fails to change from “Nothing” when selecting theproper case. I’ve kept the Section 2 option of pasting just values. (Some examples of Sheet names include: “Alpha_201907.xls”, “Beta_201907.xls”,“Charlie_201907.xls”) Any idea why?



A possible issue I thought of is running this codemultiple times would add the same data to the end of the list, but a solutionwould be to change the go the bottom of column "B" (Column"B" has same amount of rows) and off set to column A when pasting.That way values will be overwritten not doubled. Also, thank you for thewarning about any gaps, but the data should be continuous.

p45cal
02-07-2020, 10:37 AM
Looks like the difference between a hyphen (-) and an underline character (_).


Set Destn = ws.Range("B5").End(xlDown).Offset(1,-1)as long as column B isn't filled with formulae.

Trials
02-07-2020, 11:12 AM
Looks like the difference between a hyphen (-) and an underline character (_).


Set Destn = ws.Range("B5").End(xlDown).Offset(1,-1)as long as column B isn't filled with formulae.

Didn't realize that hyphen was part of the search criteria …
Works like a charm, my friend. Much appreciated!