VBA Code - Improvement if possible

H

hrayani

Well-known Member
Joined
Jul 23, 2010
Messages
1,501
Office Version
  1. 2016
Platform
  1. Windows
Hello Friends,

I am using the below code which works fine but I would like you guys to let me know if there is a better way to write it.
Like there are some line in the code which selects some sheets. Is it possible to remove that
or any other improvements if possible last row function instead of .end(xlup) etc

VBA Code: 
Private Sub update_quality_article_unit()
  
  Dim ws As Worksheet
  
  ActiveWorkbook.Unprotect Password:="2270166"
  
  Set WSArray = Workbooks("REPORTS.xlsm").Worksheets(Array("DATABASE", "Supplier Wise", "Year Wise"))
    
  For Each ws In WSArray
  ws.Visible = xlSheetVisible
  ws.Unprotect Password:="merchant"
  If ws.AutoFilterMode Then ws.AutoFilterMode = False
  Next

   Worksheets("Supplier Wise").Range("B11:D123,B129:D161").ClearContents
   Worksheets("Year Wise").Range("B11:D123,B129:D161").ClearContents
    
ActiveWorkbook.Worksheets("DATABASE").Range("orders_article").Copy Destination:=Sheets("DATABASE").Range("BA4")
ActiveWorkbook.Worksheets("DATABASE").Range("orders_quality").Copy Destination:=Sheets("DATABASE").Range("BB4")
ActiveWorkbook.Worksheets("DATABASE").Range("orders_unit").Copy Destination:=Sheets("DATABASE").Range("BC4")
    
Sheets("DATABASE").Select
    
    'Remove Duplicate Start
    Worksheets("DATABASE").Range("BA4:BC4", Range("BA4:BC4").End(xlDown)).RemoveDuplicates Columns:=Array(1, 2, 3), Header:=xlNo
    'Remove Duplicate End
    
   'Sorting Start
    Range("BA4:BC4", Range("BA4:BC4").End(xlDown)).Select
    Worksheets("DATABASE").Sort.SortFields.Clear
    Worksheets("DATABASE").Sort.SortFields.Add Key:=Range("BB4:BB4", Range("BB4:BB4").End(xlDown)), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    Worksheets("DATABASE").Sort.SortFields.Add Key:=Range("BA4:BA4", Range("BA4:BA4").End(xlDown)), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    Worksheets("DATABASE").Sort.SortFields.Add Key:=Range("BC4:BC4", Range("BC4:BC4").End(xlDown)), SortOn:=xlSortOnValues, Order:=xlAscending, CustomOrder:="Set(s),Pc(s),Pair(s),Dozen(s)", DataOption:=xlSortNormal
    With Worksheets("DATABASE").Sort
        .SetRange Range("BA4:BC4", Range("BA4:BC4").End(xlDown))
        .Header = xlGuess
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
   'Sorting End
    
    Range("BA4:BC4", Range("BA4:BC4").End(xlDown)).Copy
    
    Sheets("Supplier Wise").Range("B11").PasteSpecial Paste:=xlPasteValues
    Sheets("Year Wise").Range("B11").PasteSpecial Paste:=xlPasteValues
    
    Sheets("DATABASE").Select
    Sheets("DATABASE").Range("BB4", Range("BB4").End(xlDown)).ClearContents
    
    Range("BC4", Range("BC4").End(xlDown)).Cut Range("BB4")
        
    'Sorintg Start
    Range("BA4:BB4", Range("BA4:BB4").End(xlDown)).Select
    Worksheets("DATABASE").Sort.SortFields.Clear
    Worksheets("DATABASE").Sort.SortFields.Add Key:=Range("BA4:BA4", Range("BA4:BA4").End(xlDown)), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    Worksheets("DATABASE").Sort.SortFields.Add Key:=Range("BB4:BB4", Range("BB4:BB4").End(xlDown)), SortOn:=xlSortOnValues, Order:=xlAscending, CustomOrder:="Set(s),Pc(s),Pair(s),Dozen(s)", DataOption:=xlSortNormal
    With Worksheets("DATABASE").Sort
        .SetRange Range("BA4:BB4", Range("BA4:BB4").End(xlDown))
        .Header = xlGuess
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    'Sorting End
    
    'Remove Duplicate Start
     Range("BA4:BB4", Range("BA4:BB4").End(xlDown)).RemoveDuplicates Columns:=Array(1, 2), Header:=xlNo
    'Remove Duplicate End
    
   Range("BA4", Range("BA4").End(xlDown)).Copy
   Sheets("Supplier Wise").Range("B129").PasteSpecial Paste:=xlPasteValues
   Sheets("Year Wise").Range("B129").PasteSpecial Paste:=xlPasteValues
    
   Sheets("DATABASE").Select
   Sheets("DATABASE").Range("BB4", Range("BB4").End(xlDown)).Copy
   
   Sheets("Supplier Wise").Range("D129").PasteSpecial Paste:=xlPasteValues
   Range("C1").Select
    
   Sheets("Year Wise").Range("D129").PasteSpecial Paste:=xlPasteValues
   Range("C1").Select
    
   Sheets("DATABASE").Range("BA4:BB4", Range("BA4:BB4").End(xlDown)).ClearContents
   Range("A3").Select
    
    
    For Each ws In WSArray
   ws.Protect Password:="merchant", DrawingObjects:=True, Contents:=True, Scenarios:=True _
       , AllowFormattingColumns:=True, AllowFormattingRows:=True
     
   ws.Visible = xlSheetVeryHidden
        
   Next
   ActiveWorkbook.Protect Password:="2270166", Structure:=True, Windows:=True
    
    End Sub

Regards,

Humayun
 

Excel Facts

Why are there 1,048,576 rows in Excel?
The Excel team increased the size of the grid in 2007. There are 2^20 rows and 2^14 columns for a total of 17 billion cells.
Sort by date Sort by votes
See if the gets rid of he flicker an flash.

VBA Code: 
Private Sub update_quality_article_unit()
  Dim ws As Worksheet
  ActiveWorkbook.Unprotect Password:="2270166"
  Set WSArray = Workbooks("REPORTS.xlsm").Worksheets(Array("DATABASE", "Supplier Wise", "Year Wise"))
    For Each ws In WSArray
        ws.Visible = xlSheetVisible
        ws.Unprotect Password:="merchant"
        If ws.AutoFilterMode Then ws.AutoFilterMode = False
    Next
  Worksheets("Supplier Wise").Range("B11:D123,B129:D161").ClearContents
  Worksheets("Year Wise").Range("B11:D123,B129:D161").ClearContents
  ActiveWorkbook.Worksheets("DATABASE").Range("orders_article").Copy Destination:=Sheets("DATABASE").Range("BA4")
  ActiveWorkbook.Worksheets("DATABASE").Range("orders_quality").Copy Destination:=Sheets("DATABASE").Range("BB4")
  ActiveWorkbook.Worksheets("DATABASE").Range("orders_unit").Copy Destination:=Sheets("DATABASE").Range("BC4")
    'Remove Duplicate Start
    Worksheets("DATABASE").Range("BA4:BC4", Range("BA4:BC4").End(xlDown)).RemoveDuplicates Columns:=Array(1, 2, 3), Header:=xlNo
    'Remove Duplicate End
   'Sorting Start
    Worksheets("DATABASE").Sort.SortFields.Clear
    Worksheets("DATABASE").Sort.SortFields.Add Key:=Range("BB4:BB4", Range("BB4:BB4").End(xlDown)), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    Worksheets("DATABASE").Sort.SortFields.Add Key:=Range("BA4:BA4", Range("BA4:BA4").End(xlDown)), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    Worksheets("DATABASE").Sort.SortFields.Add Key:=Range("BC4:BC4", Range("BC4:BC4").End(xlDown)), SortOn:=xlSortOnValues, Order:=xlAscending, CustomOrder:="Set(s),Pc(s),Pair(s),Dozen(s)", DataOption:=xlSortNormal
    With Worksheets("DATABASE").Sort
        .SetRange Range("BA4:BC4", Range("BA4:BC4").End(xlDown))
        .Header = xlGuess
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
   'Sorting End
    Range("BA4:BC4", Range("BA4:BC4").End(xlDown)).Copy
    Sheets("Supplier Wise").Range("B11").PasteSpecial Paste:=xlPasteValues
    Sheets("Year Wise").Range("B11").PasteSpecial Paste:=xlPasteValues
    Sheets("DATABASE").Range("BB4", Range("BB4").End(xlDown)).ClearContents
    Range("BC4", Range("BC4").End(xlDown)).Cut Range("BB4")
    'Sorintg Start
    Worksheets("DATABASE").Sort.SortFields.Clear
    Worksheets("DATABASE").Sort.SortFields.Add Key:=Range("BA4:BA4", Range("BA4:BA4").End(xlDown)), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    Worksheets("DATABASE").Sort.SortFields.Add Key:=Range("BB4:BB4", Range("BB4:BB4").End(xlDown)), SortOn:=xlSortOnValues, Order:=xlAscending, CustomOrder:="Set(s),Pc(s),Pair(s),Dozen(s)", DataOption:=xlSortNormal
    With Worksheets("DATABASE").Sort
        .SetRange Range("BA4:BB4", Range("BA4:BB4").End(xlDown))
        .Header = xlGuess
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    'Sorting End
    'Remove Duplicate Start
    Range("BA4:BB4", Range("BA4:BB4").End(xlDown)).RemoveDuplicates Columns:=Array(1, 2), Header:=xlNo
    'Remove Duplicate End
    Range("BA4", Range("BA4").End(xlDown)).Copy
    Sheets("Supplier Wise").Range("B129").PasteSpecial Paste:=xlPasteValues
    Sheets("Year Wise").Range("B129").PasteSpecial Paste:=xlPasteValues
    Sheets("DATABASE").Range("BB4", Range("BB4").End(xlDown)).Copy
    Sheets("Supplier Wise").Range("D129").PasteSpecial Paste:=xlPasteValues
    Sheets("Year Wise").Range("D129").PasteSpecial Paste:=xlPasteValues
    Sheets("DATABASE").Range("BA4:BB4", Range("BA4:BB4").End(xlDown)).ClearContents
    For Each ws In WSArray
        ws.Protect Password:="merchant", DrawingObjects:=True, Contents:=True, Scenarios:=True _
        , AllowFormattingColumns:=True, AllowFormattingRows:=True
        ws.Visible = xlSheetVeryHidden
    Next
   ActiveWorkbook.Protect Password:="2270166", Structure:=True, Windows:=True
End Sub
 
Upvote 0
run time error: Application Defined or object-defined error

with this part of the code highlighted ?
VBA Code: 
    Worksheets("DATABASE").Range("BA4:BC4", Range("BA4:BC4").End(xlDown)).RemoveDuplicates Columns:=Array(1, 2, 3), Header:=xlNo
 
Upvote 0
Don't know. I didn't change anything related to that statement and the statement appears to be valid.
BTW, I was wondering why you are using Private in the macro title. Are you running the code from a worksheet or userform module? If you are running it from a standard module like module1, then the 'Private' should be removed.
 
Upvote 0
Try it like
VBA Code: 
With Worksheets("DATABASE")
   .Range("BA4:BC4", .Range("BA4:BC4").End(xlDown)).RemoveDuplicates Columns:=Array(1, 2, 3), Header:=xlNo
End With
 
Upvote 0
Fluff said:
Try it like
VBA Code: 
With Worksheets("DATABASE")
   .Range("BA4:BC4", .Range("BA4:BC4").End(xlDown)).RemoveDuplicates Columns:=Array(1, 2, 3), Header:=xlNo
End With
Click to expand...
Hello Fluff,

Thanks for the reply...

Few questions here

VBA Code: 
 With Worksheets("DATABASE")
    .Range("BA4:BC4", .Range("BA4:BC4").End(xlDown)).Copy Destination:=Sheets("Supplier Wise").Range("B11")
    .Range("BA4:BC4", .Range("BA4:BC4").End(xlDown)).Copy Destination:=Sheets("Year Wise").Range("B11")
    .Range("BB4", .Range("BB4").End(xlDown)).ClearContents
    .Range("BC4", .Range("BC4").End(xlDown)).Cut .Range("BB4")
    End With

1) how to copy and paste special as xlpastevalues in the destination in the above scenario
2) how to copy once and paste at two or more destination at the same time
like in the example above you can see that I have to copy twice.
 
Upvote 0
Try
VBA Code: 
   With Worksheets("DATABASE")
      With .Range("BA4:BC4", .Range("BA4:BC4").End(xlDown))
         Sheets("Supplier Wise").Range("B11").Resize(.Rows.Count, 3).Value = .Value
         Sheets("Year Wise").Range("B11").Resize(.Rows.Count, 3).Value = .Value
      End With
      .Range("BB4", .Range("BB4").End(xlDown)).ClearContents
      .Range("BC4", .Range("BC4").End(xlDown)).Cut .Range("BB4")
   End With
 
Upvote 0
Fluff said:
Try
VBA Code: 
   With Worksheets("DATABASE")
      With .Range("BA4:BC4", .Range("BA4:BC4").End(xlDown))
         Sheets("Supplier Wise").Range("B11").Resize(.Rows.Count, 3).Value = .Value
         Sheets("Year Wise").Range("B11").Resize(.Rows.Count, 3).Value = .Value
      End With
      .Range("BB4", .Range("BB4").End(xlDown)).ClearContents
      .Range("BC4", .Range("BC4").End(xlDown)).Cut .Range("BB4")
   End With
Click to expand...
Bingo (y) ?

But educate me that what is Resize(.Rows.Count, 3).value= .value

Specially 3 after the count... What does 3 refers to ???
 
Upvote 0
Mostly went over my head... But still

3 refers to the column number .... So if the range is starting from B11 then 3 must be referring to columns B to D
And this is because the copy range is BA4:BC4 > that's 3 columns so the data is pasted from B11:D11 and the way down....

If yes then resizing is maintaining the borders and formats etc...

Did I understood this correctly... ???
 
Upvote 0
You must log in or register to reply here.

Similar threads

I
  • Question
Macro recorded to sort colm,n A-Z so now need to condense it
Replies
4
Views
102
Micron
M
O
  • Solved
VBA: Deleting Visible rows using Auto Filter; Excluding Header
Replies
4
Views
416
mumps
mumps
Dazzawm
  • Question
Change Recorded Range To Used Range.
2
Replies
12
Views
388
Dazzawm
Dazzawm
Dazzawm
  • Solved
Slight Amendment To Code
Replies
6
Views
303
Dazzawm
Dazzawm
T
  • Solved
Error when sorting table - with exact same code that is working elsewhere
Replies
2
Views
99
TheRedCardinal
T

Forum statistics

Threads
1,215,328
Messages
6,124,295
Members
449,149
Latest member
mwdbActuary

Share this page

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
Back
Top