Use same VBA code for multiple Sheets in a Workbook

A

Andy0311

Board Regular
Joined
Oct 16, 2019
Messages
118
Office Version
  1. 365
  2. 2016
Platform
  1. Windows
Hello,

A while back I was trying to figure out how to count distinct days from a column in a seat time report I run. Mark88 provided this code (see below), which works flawlessly. I run it for each sheet in my workbook by clicking on sheet 1, run the code, click on sheet2, run the code, etc. for each sheet. Could this code be modified so that it could be run in sheet1, and then automatically loop to run in every other sheet in my workbook? Here's the code:

Code: 
Sub DistinctDays2Mark88MrExcel()
    Dim myrow As Long, arr, mycell

    Application.ScreenUpdating = False
    Columns("D:F").UnMerge
    Columns("B:H").EntireColumn.AutoFit

    Range("D6:D" & Range("D" & Rows.Count).End(xlUp).Row).Copy Range("J6")

    Columns("J:J").ColumnWidth = 27.71


    Range("J6:J" & Range("J" & Rows.Count).End(xlUp).Row).TextToColumns Destination:=Range("J6"), DataType:=xlDelimited, _
        TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=True, Tab:=False, _
        Semicolon:=False, Comma:=False, Space:=True, Other:=False, FieldInfo _
        :=Array(Array(1, 1), Array(2, 1), Array(3, 1)), TrailingMinusNumbers:=True

   
    myrow = Cells(Rows.Count, "J").End(xlUp).Row - 5
    arr = Range("J6").Resize(myrow)
    With CreateObject("scripting.dictionary")
        For Each mycell In arr
            mycell = Trim(mycell)
            If Not .Exists(mycell) Then
                .Add mycell, Empty
                arr(.Count, 1) = mycell
            End If
        Next mycell
        Range("J6").Resize(myrow).ClearContents
        Range("J6").Resize(.Count) = arr
    End With

    Columns("E:F").Delete Shift:=xlToLeft
    Columns("I:J").Delete Shift:=xlToLeft
    Range("H4").FormulaR1C1 = "=COUNTA(R[2]C:R[18]C)"

    Application.ScreenUpdating = True
End Sub

Thanks again, Mark88 for the help in my original post.

Andy
 
Last edited by a moderator:

Excel Facts

How to create a cell-sized chart?
Tiny charts, called Sparklines, were added to Excel 2010. Look for Sparklines on the Insert tab.
Sort by date Sort by votes
Try this

VBA Code: 
Sub DistinctDays2Mark88MrExcel()
    Dim myrow As Long, arr, mycell
  Dim sh As Worksheet
    Application.ScreenUpdating = False
 
  For Each sh In Sheets
    sh.Columns("D:F").UnMerge
    sh.Columns("B:H").EntireColumn.AutoFit

    sh.Range("D6:D" & sh.Range("D" & Rows.Count).End(xlUp).Row).Copy sh.Range("J6")

    sh.Columns("J:J").ColumnWidth = 27.71


    sh.Range("J6:J" & Range("J" & Rows.Count).End(xlUp).Row).TextToColumns Destination:=sh.Range("J6"), _
        DataType:=xlDelimited, TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=True, Tab:=False, _
        Semicolon:=False, Comma:=False, Space:=True, Other:=False, FieldInfo _
        :=Array(Array(1, 1), Array(2, 1), Array(3, 1)), TrailingMinusNumbers:=True

    
    myrow = sh.Cells(Rows.Count, "J").End(xlUp).Row - 5
    arr = sh.Range("J6").Resize(myrow)
    With CreateObject("scripting.dictionary")
        For Each mycell In arr
            mycell = Trim(mycell)
            If Not .Exists(mycell) Then
                .Add mycell, Empty
                arr(.Count, 1) = mycell
            End If
        Next mycell
        sh.Range("J6").Resize(myrow).ClearContents
        sh.Range("J6").Resize(.Count) = arr
    End With

    sh.Columns("E:F").Delete Shift:=xlToLeft
    sh.Columns("I:J").Delete Shift:=xlToLeft
    sh.Range("H4").FormulaR1C1 = "=COUNTA(R[2]C:R[18]C)"

    Application.ScreenUpdating = True
  Next
End Sub
 
Upvote 0
How about
VBA Code: 
Sub DistinctDays2Mark88MrExcel()
    Dim myrow As Long, arr, mycell
    Dim Ws As Worksheet
    
    Application.ScreenUpdating = False
    For Each Ws In Worksheets
        Ws.Columns("D:F").UnMerge
        Ws.Columns("B:H").EntireColumn.AutoFit
    
        Ws.Range("D6:D" & Ws.Range("D" & Rows.Count).End(xlUp).Row).Copy Ws.Range("J6")
    
        Ws.Columns("J:J").ColumnWidth = 27.71
    
    
        Ws.Range("J6:J" & Ws.Range("J" & Rows.Count).End(xlUp).Row).TextToColumns Destination:=Ws.Range("J6"), DataType:=xlDelimited, _
            TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=True, Tab:=False, _
            Semicolon:=False, Comma:=False, Space:=True, Other:=False, FieldInfo _
            :=Array(Array(1, 1), Array(2, 1), Array(3, 1)), TrailingMinusNumbers:=True
    
        
        myrow = Ws.Cells(Rows.Count, "J").End(xlUp).Row - 5
        arr = Ws.Range("J6").Resize(myrow)
        With CreateObject("scripting.dictionary")
            For Each mycell In arr
                mycell = Trim(mycell)
                If Not .Exists(mycell) Then
                    .Add mycell, Empty
                    arr(.Count, 1) = mycell
                End If
            Next mycell
            Ws.Range("J6").Resize(myrow).ClearContents
            Ws.Range("J6").Resize(.Count) = arr
        End With
    
        Ws.Columns("E:F").Delete Shift:=xlToLeft
        Ws.Columns("I:J").Delete Shift:=xlToLeft
        Ws.Range("H4").FormulaR1C1 = "=COUNTA(R[2]C:R[18]C)"
    Next Ws
    Application.ScreenUpdating = True
End Sub
 
Upvote 0
Only a small correction in my code in this line:

Rich (BB code): 
    sh.Range("J6:J" & sh.Range("J" & Rows.Count).End(xlUp).Row).TextToColumns Destination:=sh.Range("J6"), _
        DataType:=xlDelimited, TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=True, Tab:=False, _
        Semicolon:=False, Comma:=False, Space:=True, Other:=False, FieldInfo _
        :=Array(Array(1, 1), Array(2, 1), Array(3, 1)), TrailingMinusNumbers:=True
 
Last edited by a moderator:
Upvote 0
Fluff said:
How about
VBA Code: 
Sub DistinctDays2Mark88MrExcel()
    Dim myrow As Long, arr, mycell
    Dim Ws As Worksheet
   
    Application.ScreenUpdating = False
    For Each Ws In Worksheets
        Ws.Columns("D:F").UnMerge
        Ws.Columns("B:H").EntireColumn.AutoFit
   
        Ws.Range("D6:D" & Ws.Range("D" & Rows.Count).End(xlUp).Row).Copy Ws.Range("J6")
   
        Ws.Columns("J:J").ColumnWidth = 27.71
   
   
        Ws.Range("J6:J" & Ws.Range("J" & Rows.Count).End(xlUp).Row).TextToColumns Destination:=Ws.Range("J6"), DataType:=xlDelimited, _
            TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=True, Tab:=False, _
            Semicolon:=False, Comma:=False, Space:=True, Other:=False, FieldInfo _
            :=Array(Array(1, 1), Array(2, 1), Array(3, 1)), TrailingMinusNumbers:=True
   
       
        myrow = Ws.Cells(Rows.Count, "J").End(xlUp).Row - 5
        arr = Ws.Range("J6").Resize(myrow)
        With CreateObject("scripting.dictionary")
            For Each mycell In arr
                mycell = Trim(mycell)
                If Not .Exists(mycell) Then
                    .Add mycell, Empty
                    arr(.Count, 1) = mycell
                End If
            Next mycell
            Ws.Range("J6").Resize(myrow).ClearContents
            Ws.Range("J6").Resize(.Count) = arr
        End With
   
        Ws.Columns("E:F").Delete Shift:=xlToLeft
        Ws.Columns("I:J").Delete Shift:=xlToLeft
        Ws.Range("H4").FormulaR1C1 = "=COUNTA(R[2]C:R[18]C)"
    Next Ws
    Application.ScreenUpdating = True
End Sub
Click to expand...
Hi Fluff,
This code worked spectacularly and completely solved my problem! Thank you for helping me again, and for all the other times. Best,
Andy
 
Upvote 0
You must log in or register to reply here.

Similar threads

C
  • Question
Print from database
Replies
0
Views
115
Charlreena
C
BradleyS
  • Solved
AutoFilter using string array not working
Replies
2
Views
513
BradleyS
BradleyS
I
  • Solved
General questiion about my code on two different sheet
Replies
2
Views
232
ipbr21054
I
H
  • Solved
Amend the VBA code to Filter Columns Instead of Rows
Replies
9
Views
136
Akuini
Akuini
D
  • Solved
Search value in textbox1 in the listbox1 with array doesn't work
Replies
4
Views
143
david2005wang
D

Forum statistics

Threads
1,214,520
Messages
6,120,013
Members
448,935
Latest member
ijat

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