VBA for copy and paste between worksheets

abschy

New Member
Joined
Mar 20, 2019
Messages
25
Hi all,

I have a worksheet that has multiple sheets of data, and i want to consolidate the data into 1 page of unique values.

I have this code written but want to shorten it by using some loops for the copying and pasting.

What my code does:
1) copies data from column "Project Name" and pastes it in sheet "REF_PROJNAME"
2) i repeated this code 3 more times for 3 other different sheets that i want to copy data from
3) then i remove duplicates and sort the unique names in alphabetical order
4) data validation is done to create a list on sheet "Find Project" in cell "F8"
5) sheet "REF_PROJNAME" is then hidden

I only want to copy data from the 4 sheets that i copy from in the below code, and have 3 more sheets that i do not want to be touched.

I have tried multiple methods from other forums online including listing out the sheet names in an array, but they all do not see to work with my code below..

Would appreciate any help whatsoever!!

Thank you!!



Code:
Sub UNIQUEPROJNAME()
' Creating new updated list of unique project names


 Dim lastrow As Long
     
  ' copy data
    Sheets("CAPEX_PERM_DATA").Select
    Range("AD2").Clear
    Range("CAPEX[PROJECT NAME]").Select
    Selection.Copy
    Sheets("REF_PROJNAME").Select
    Range("A1").Select
    ActiveSheet.Paste
    
    Sheets("OPEX_OTHERS_DATA").Select
    Range("AD2").Clear
    Range("OPEX_OTHERS[PROJECT NAME]").Select
    Selection.Copy
    Sheets("REF_PROJNAME").Select
    lastrow = Cells(Rows.Count, 1).End(xlUp).Row
    Cells(lastrow, 1).Offset(1, 0).Select
    ActiveSheet.Paste
    
    Sheets("OPEX_FY20TEMP_DATA").Select
    Range("AD2").Clear
    Range("OPEX_FY20_TEMP[PROJECT NAME]").Select
    Selection.Copy
    Sheets("REF_PROJNAME").Select
    lastrow = Cells(Rows.Count, 1).End(xlUp).Row
    Cells(lastrow, 1).Offset(1, 0).Select
    ActiveSheet.Paste
    
    Sheets("OPEX_FY19TEMP_DATA").Select
    Range("AD2").Clear
    Range("OPEX_FY19_TEMP[PROJECT NAME]").Select
    Selection.Copy
    Sheets("REF_PROJNAME").Select
    lastrow = Cells(Rows.Count, 1).End(xlUp).Row
    Cells(lastrow, 1).Offset(1, 0).Select
    ActiveSheet.Paste
    
' remove duplicates
    Columns("A:A").Select
    Application.CutCopyMode = False
    Application.CutCopyMode = False
    Application.CutCopyMode = False
    Range("A:A").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range( _
        "REF_PROJNAME!Extract"), Unique:=True
        
    Columns("B:B").Select
    ActiveWorkbook.Worksheets("REF_PROJNAME").sort.SortFields.Clear
    ActiveWorkbook.Worksheets("REF_PROJNAME").sort.SortFields.Add2 Key:=Range( _
        "B1"), SortOn:=xlSortOnValues, order:=xlAscending, DataOption:= _
        xlSortNormal
    With ActiveWorkbook.Worksheets("REF_PROJNAME").sort
        .SetRange Range("B1:B263")
        .Header = xlNo
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
 
' data validation to create drop down list
    Sheets("Find Project").Select
    Range("F8").Select
    With Selection.Validation
        .Delete
        .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
        xlBetween, Formula1:="=REF_PROJNAME!$B$1:$B$188"
        .IgnoreBlank = True
        .InCellDropdown = True
        .InputTitle = ""
        .ErrorTitle = ""
        .InputMessage = ""
        .ErrorMessage = ""
        .ShowInput = True
        .ShowError = True
    End With
    
  
    Worksheets("REF_PROJNAME").Visible = False
    Sheets("Find Project").Select
    Range("F8").Select
    
    
End Sub
 

Some videos you may like

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.

mohadin

Active Member
Joined
Mar 22, 2015
Messages
361
Office Version
2013
Platform
Windows
Hi
You may use the method
MY_Sheets = Array("OPEX_FY20TEMP_DATA", "OPEX_FY19TEMP_DATA", "OPEX_OTHERS_DATA", "CAPEX_PERM_DATA",......)
And loop thru the array-Mysheets
Myaheets(0)=OPEX_FY20TEMP_DATA
Myaheets(1)=OPEX_FY19TEMP_DATA
.
.

And so on
I hope this can help
 

LlebKcir

Board Regular
Joined
Oct 8, 2018
Messages
203
One thing I have picked up from here is to user .value=.value instead of .copy .paste

Rich (BB code):
' copy data    Sheets("CAPEX_PERM_DATA").Select
    Range("AD2").Clear
    Range("CAPEX[PROJECT NAME]").Select
    Selection.Copy
    Sheets("REF_PROJNAME").Select
    Range("A1").Select
    ActiveSheet.Paste
can be shortened to:
Rich (BB code):
' copy data    Sheets("CAPEX_PERM_DATA").Select
    Range("AD2").Clear
    Range("CAPEX[PROJECT NAME]").value = Sheets("REF_PROJNAME").value
https://excel-macro.tutorialhorizon...-names-of-all-worksheets-in-a-excel-workbook/

Something along that line might help point you in a direction for looping in the worksheet names as variables.
 

gallen

Well-known Member
Joined
Jun 27, 2011
Messages
1,996
Can definitely be shortened. Also more efficient t disable events and screen while doing the work,

I've started you off here. Read the comments.

Code:
Sub UNIQUEPROJNAME()
' Creating new updated list of unique project names




 Dim lastrow As Long
 
 
 On Error GoTo errHandle
 Application.EnableEvents = False
 Application.ScreenUpdating = False
     
  ' copy data
'    Sheets("CAPEX_PERM_DATA").Select
'    Range("AD2").Clear
'    Range("CAPEX[PROJECT NAME]").Select
'    Selection.Copy
'    Sheets("REF_PROJNAME").Select
'    Range("A1").Select
'    ActiveSheet.Paste
    
    'The above Becomes
    With Sheets("CAPEX_PERM_DATA")
        .Range("AD2").Clear
        .Range("CAPEX[PROJECT NAME]").Copy Sheets("REF_PROJNAME").Range("A1")
    End With


    
'________________________________________________________________________________________
    
'    Sheets("OPEX_OTHERS_DATA").Select
'    Range("AD2").Clear
'    Range("OPEX_OTHERS[PROJECT NAME]").Select
'    Selection.Copy
'    Sheets("REF_PROJNAME").Select
'    lastrow = Cells(Rows.Count, 1).End(xlUp).Row
'    Cells(lastrow, 1).Offset(1, 0).Select
'    ActiveSheet.Paste
    
    'The above becomes:
    With Sheets("OPEX_OTHERS_DATA")
        lastrow = .Cells(.Rows.Count, 1).End(xlUp).Row
        .Range("AD2").Clear
        .Range("OPEX_OTHERS[PROJECT NAME]").Copy Sheets("OPEX_OTHERS_DATA").Cells(lastrow + 1, 1)
    End With
        
        
        'and so on...
'________________________________________________________________________________________________
    
    Sheets("OPEX_FY20TEMP_DATA").Select
    Range("AD2").Clear
    Range("OPEX_FY20_TEMP[PROJECT NAME]").Select
    Selection.Copy
    Sheets("REF_PROJNAME").Select
    lastrow = Cells(Rows.Count, 1).End(xlUp).Row
    Cells(lastrow, 1).Offset(1, 0).Select
    ActiveSheet.Paste
    
    
    
    Sheets("OPEX_FY19TEMP_DATA").Select
    Range("AD2").Clear
    Range("OPEX_FY19_TEMP[PROJECT NAME]").Select
    Selection.Copy
    Sheets("REF_PROJNAME").Select
    lastrow = Cells(Rows.Count, 1).End(xlUp).Row
    Cells(lastrow, 1).Offset(1, 0).Select
    ActiveSheet.Paste
    
' remove duplicates
    Columns("A:A").Select
    Application.CutCopyMode = False
    Application.CutCopyMode = False
    Application.CutCopyMode = False
    Range("A:A").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range( _
        "REF_PROJNAME!Extract"), Unique:=True
        
    Columns("B:B").Select
    ActiveWorkbook.Worksheets("REF_PROJNAME").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("REF_PROJNAME").Sort.SortFields.Add2 Key:=Range( _
        "B1"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
        xlSortNormal
    With ActiveWorkbook.Worksheets("REF_PROJNAME").Sort
        .SetRange Range("B1:B263")
        .Header = xlNo
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
 
' data validation to create drop down list
    Sheets("Find Project").Select
    Range("F8").Select
    With Selection.Validation
        .Delete
        .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
        xlBetween, Formula1:="=REF_PROJNAME!$B$1:$B$188"
        .IgnoreBlank = True
        .InCellDropdown = True
        .InputTitle = ""
        .ErrorTitle = ""
        .InputMessage = ""
        .ErrorMessage = ""
        .ShowInput = True
        .ShowError = True
    End With
    
  
    Worksheets("REF_PROJNAME").Visible = False
    Sheets("Find Project").Select
    Range("F8").Select
    
    Application.EnableEvents = True
    Application.ScreenUpdating = True
 
Exit Sub
 
errHandle:
    MsgBox Err.Description, vbCritical
    Application.EnableEvents = True
    Application.ScreenUpdating = True
    
End Sub
 

Watch MrExcel Video

Forum statistics

Threads
1,099,805
Messages
5,470,888
Members
406,733
Latest member
darzu

This Week's Hot Topics

Top