VBA for copy and paste between worksheets

[abschy]

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!!

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

 

[mohadin]

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]

One thing I have picked up from here is to user .value=.value instead of .copy .paste

' 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:

' 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]

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.

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