Small updates to VBA Macro code

krazyness

New Member
Joined
Jan 31, 2017
Messages
23
Office Version
  1. 365
Platform
  1. Windows
Hi all - i hired someone years ago and they created the below code. Now with COVID i need a small change and cannot locate said person that created this for me.

Column A in the data now has a time in it. I need that time to be cleaned like he did with Column AB. Column A always shows date and time like this:
7/31/2020 13:00:00

I would like to sort by that time first before the other sorts also.

Then have the remaining "time" data printed just like AB's remaining is after being split... but in column A.

I hope that makes sense. and anyone can help as everything i've tried can never get it done correctly.


VBA Code:
Sub Macro1()
Dim LastRow As Long, r As Long
Dim myInput
myInput = InputBox("Enter Docket Date", "Enter Docket Date")
ActiveWorkbook.Worksheets("Jan 12 docket").PageSetup.LeftHeader = "&""Arial,Bold""&28 DOCKET: " & myInput
ActiveWorkbook.Worksheets("Jan 12 docket").PageSetup.RightHeader = "&P"
Sheets(Sheet1.Name).Activate
LastRow = Range("A" & Range("A:A").Rows.Count).End(xlUp).Row
Range("AB2:AB" & LastRow) = Evaluate("=Index(Mid(" & Range("AB2:AB" & LastRow).Address & ", " & "find("":""," & Range("AB2:AB" & LastRow).Address & ") + 2,find("",""," & Range("AB2:AB" & LastRow).Address & ")-find("":""," & Range("AB2:AB" & LastRow).Address & ") -2),)")
'Sort all of the data
ActiveWorkbook.Worksheets("Jan 12 docket").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("Jan 12 docket").Sort.SortFields.Add Key:=Range( _
    "AB2:AB" & LastRow), SortOn:=xlSortOnValues, Order:=xlAscending, CustomOrder:="Answer Hearing,Aid of Execution,Order Back,Citation,Bond Appearance", DataOption:= _
    xlSortNormal
ActiveWorkbook.Worksheets("Jan 12 docket").Sort.SortFields.Add Key:=Range( _
    "D2:D" & LastRow), SortOn:=xlSortOnValues, Order:=xlAscending, CustomOrder:="Answer Hearing,Aid of Execution,Order Back,Citation,Bond Appearance", DataOption:= _
    xlSortNormal
ActiveWorkbook.Worksheets("Jan 12 docket").Sort.SortFields.Add Key:=Range( _
    "U2:U" & LastRow), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:= _
    xlSortNormal
With ActiveWorkbook.Worksheets("Jan 12 docket").Sort
    .SetRange Range("A1:AB" & LastRow)
    .Header = xlYes
    .MatchCase = False
    .Orientation = xlTopToBottom
    .SortMethod = xlPinYin
    .Apply
End With
'Delete columns that are not needed
Columns("A:C").Delete Shift:=xlToLeft
Columns("B:Q").Delete Shift:=xlToLeft
Columns("D:H").Delete Shift:=xlToLeft
'Add Notes column
Range("D1") = "Notes"
'Arrange columns correctly
Columns("B:B").Cut
Columns("A:A").Insert
Application.CutCopyMode = False
'Split case_style_comp into two lines
r = 2
Do
    Rows(r + 1).Insert
   
    'Split case sides if "vs." is found
    If InStr(1, Cells(r, 3), "vs.") > 0 Then
        Cells(r + 1, 3) = Trim(Right(Cells(r, 3), Len(Cells(r, 3)) - InStr(1, Cells(r, 3), "vs.") - 4))
        Cells(r, 3) = Trim(Left(Cells(r, 3), InStr(1, Cells(r, 3), "vs.") + 3))
    End If
   
    Cells(r + 1, 2) = Cells(r, 4)
   
    Range("A" & r).Resize(2, 4).BorderAround ColorIndex:=1, Weight:=xlThin
    Range("A" & r).Resize(2, 3).BorderAround ColorIndex:=1, Weight:=xlThin
    r = r + 2
Loop While Cells(r, 1) <> ""
'Clear notes
Range("D2:D" & r).ClearContents
'fontsize
Columns("A:D").Font.Size = 14
'orientation
ActiveSheet.PageSetup.Orientation = xlLandscape
'fit all columns
With Worksheets("Jan 12 docket").PageSetup
.Zoom = False
.FitToPagesWide = 1
End With
'Autofit columns
Columns("A:C").AutoFit
Columns("D").ColumnWidth = 60
End Sub
 
Last edited by a moderator:

Caleeco

Well-known Member
Joined
Jan 9, 2016
Messages
968
Could you please test the code below. I think it should do what you want, but let me know if the output is correct. I have attached a picture of how it looks on my end.

I've not had time to look into sorting by time yet... this will have to be a job for tomorrow!

Caseformat.JPG


VBA Code:
Sub Macro1()
'//---| v1.0 | Process courtroom data and output summary table
'------------------------
    Dim myInput     As Variant
    Dim lr          As Long         'Last row of Docket Data
    Dim r           As Long         'Loop Counter
    Dim DocketDate  As String       'User Entered Docket Date to Put in Header
    Dim ws          As Worksheet    'Sheet 1 Data
    
    ' Set Worksheet Reference for Data & Add Docket Date to the Page Header
    Set ws = ActiveWorkbook.Sheets("Jan 12 docket")
    DocketDate = InputBox("Enter Docket Date", "Enter Docket Date")
    ws.Activate
    ws.PageSetup.LeftHeader = "&""Arial,Bold""&28 DOCKET: " & myInput
    ws.PageSetup.RightHeader = "&P"
    
    'Find the Last Row of the Data
    lr = ws.Range("A" & Rows.Count).End(xlUp).Row
    
    'Extract the first Attorney Name from the Case_Attorneys field
    Range("AB2:AB" & lr) = Evaluate("=Index(Mid(" & Range("AB2:AB" & lr).Address & ", " & "find("":""," & Range("AB2:AB" & lr).Address & ") + 2,find("",""," & Range("AB2:AB" & lr).Address & ")-find("":""," & Range("AB2:AB" & lr).Address & ") -2),)")
    
    'Extract the time from the Docket
    ws.Range("A2:A" & lr) = Evaluate("=Text(" & ws.Range("A2:A" & lr).Address & ",""hh:mm"")")
    
    'Apply Sorting to the table
    ws.Sort.SortFields.Clear
    ws.Sort.SortFields.Add Key:=Range("AB2:AB" & lr), SortOn:=xlSortOnValues, Order:=xlAscending, CustomOrder:="Answer Hearing,Aid of Execution,Order Back,Citation,Bond Appearance", DataOption:=xlSortNormal
    ws.Sort.SortFields.Add Key:=Range("D2:D" & lr), SortOn:=xlSortOnValues, Order:=xlAscending, CustomOrder:="Answer Hearing,Aid of Execution,Order Back,Citation,Bond Appearance", DataOption:=xlSortNormal
    ws.Sort.SortFields.Add Key:=Range("U2:U" & lr), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
    
    With ws.Sort
        .SetRange Range("A1:AB" & lr)
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    
    'Delete columns that are not needed
    ws.Columns("W:AA").Delete Shift:=xlToLeft
    ws.Columns("E:T").Delete Shift:=xlToLeft
    ws.Columns("B:C").Delete Shift:=xlToLeft
    
    'Switch Case_fmt & Type Columns
    ws.Columns("C:C").Cut
    ws.Columns("B:B").Insert
    
    'Move Docket Start Time to Column F
    ws.Columns("A:A").Cut
    ws.Columns("F:F").Insert
    Application.CutCopyMode = False
    
    'Add Notes column
    ws.Range("D1") = "Notes"
    
    'Split case_style_comp into two lines
    r = 2
    
    Do
        Rows(r + 1).Insert
    
       'Add Docket Time to new row
       Cells(r + 1, 1) = Format(Cells(r, 5), "hh:mm")
      
        'Split case sides if "vs." is found
        If InStr(1, Cells(r, 3), "vs.") > 0 Then
            Cells(r + 1, 3) = Trim(Right(Cells(r, 3), Len(Cells(r, 3)) - InStr(1, Cells(r, 3), "vs.") - 3))
            Cells(r, 3) = Trim(Left(Cells(r, 3), InStr(1, Cells(r, 3), "vs.") + 3))
        End If
      
        Cells(r + 1, 2) = Cells(r, 4)
      
        Range("A" & r).Resize(2, 4).BorderAround ColorIndex:=1, Weight:=xlThin
        Range("A" & r).Resize(2, 3).BorderAround ColorIndex:=1, Weight:=xlThin
        r = r + 2
    Loop While Cells(r, 1) <> ""
    
    'Clear Junk Data & Change FontSize
    Range("D2:D" & r).ClearContents 'Notes
    Range("E1:E" & lr).Clear        'Time
    Columns("A:D").Font.Size = 14
    
    'Orientation
    ActiveSheet.PageSetup.Orientation = xlLandscape
    
    'Fit Columns to View
    With ws.PageSetup
        .Zoom = False
        .FitToPagesWide = 1
    End With
    
    'Autofit columns
    ws.Columns("A:C").AutoFit
    ws.Columns("D").ColumnWidth = 60

End Sub
 

Excel Facts

Which Excel functions can ignore hidden rows?
The SUBTOTAL and AGGREGATE functions ignore hidden rows. AGGREGATE can also exclude error cells and more.

krazyness

New Member
Joined
Jan 31, 2017
Messages
23
Office Version
  1. 365
Platform
  1. Windows
close!

it left a little garbage on the right... but not a huge deal...

1596661493972.png
 

krazyness

New Member
Joined
Jan 31, 2017
Messages
23
Office Version
  1. 365
Platform
  1. Windows
so thank you so much. first. that's way important.

second - i did lose a few divider lines, in between A and B and B and C, as well as the myInput data. (docket date) is lost when it prints.
 

Caleeco

Well-known Member
Joined
Jan 9, 2016
Messages
968
Ah i know what that is... I used the Last Row from the data at the start... but the rows have doubled by the end.

Change this block (towards the end)
VBA Code:
    'Clear Junk Data & Change FontSize
    Range("D2:D" & r).ClearContents 'Notes
    Range("E1:E" & lr).Clear      'Time
    Columns("A:D").Font.Size = 14

to this

VBA Code:
    'Clear Junk Data & Change FontSize
    Range("D2:D" & r).ClearContents 'Notes
    Range("E1:E" & lr * 3).Clear      'Time
    Columns("A:D").Font.Size = 14

That should get rid of the junk!
 

Caleeco

Well-known Member
Joined
Jan 9, 2016
Messages
968

ADVERTISEMENT

so thank you so much. first. that's way important.

second - i did lose a few divider lines, in between A and B and B and C, as well as the myInput data. (docket date) is lost when it prints.

Hmm ok, not sure why the dividers went missing. I will investigate!

What do you mean by the Docket date being missing? It doesnt appear in the header of the sheet?
 

krazyness

New Member
Joined
Jan 31, 2017
Messages
23
Office Version
  1. 365
Platform
  1. Windows
Hmm ok, not sure why the dividers went missing. I will investigate!

What do you mean by the Docket date being missing? It doesnt appear in the header of the sheet?
correct. it brought the input box.. i typed the date. when printed... it does not appear.
 

krazyness

New Member
Joined
Jan 31, 2017
Messages
23
Office Version
  1. 365
Platform
  1. Windows

ADVERTISEMENT

that did fix the "junk" on the right!
 

Caleeco

Well-known Member
Joined
Jan 9, 2016
Messages
968
correct. it brought the input box.. i typed the date. when printed... it does not appear.

Sorry, I had switched the variable name! Its now called 'DocketDate'

Near the top, change this line:
VBA Code:
ws.PageSetup.LeftHeader = "&""Arial,Bold""&28 DOCKET: " & myInput

to this:
Code:
ws.PageSetup.LeftHeader = "&""Arial,Bold""&28 DOCKET: " & DocketDate

Cheers
Caleeco
 

Caleeco

Well-known Member
Joined
Jan 9, 2016
Messages
968
Hey,

Had a bit more time to work on this. The code below should fix the Border issues & sort the dockets by Start Time.

Let me know if it works as expected on your end.

Thanks
Caleeco

VBA Code:
Sub Macro1()
'//---| v1.0 | Process courtroom data and output summary table
'------------------------
    Dim lr          As Long         'Last row of Docket Data
    Dim r           As Long         'Loop Counter
    Dim DocketDate  As String       'User Entered Docket Date to Put in Header
    Dim ws          As Worksheet    'Sheet 1 Data
    
    ' Set Worksheet Reference for Data & Add Docket Date to the Page Header
    Set ws = ActiveWorkbook.Sheets("Jan 12 docket")
    DocketDate = InputBox("Enter Docket Date", "Enter Docket Date")
    ws.Activate
    ws.PageSetup.LeftHeader = "&""Arial,Bold""&28 DOCKET: " & DocketDate
    ws.PageSetup.RightHeader = "&P"
    
    'Find the Last Row of the Data
    lr = ws.Range("A" & Rows.Count).End(xlUp).Row
    
    'Extract the first Attorney Name from the Case_Attorneys field
    Range("AB2:AB" & lr) = Evaluate("=Index(Mid(" & Range("AB2:AB" & lr).Address & ", " & "find("":""," & Range("AB2:AB" & lr).Address & ") + 2,find("",""," & Range("AB2:AB" & lr).Address & ")-find("":""," & Range("AB2:AB" & lr).Address & ") -2),)")
    
    'Extract the time from the Docket
    ws.Range("A2:A" & lr) = Evaluate("=Text(" & ws.Range("A2:A" & lr).Address & ",""hh:mm"")")
    
    'Apply Sorting to the table
    ws.Sort.SortFields.Clear
    ws.Sort.SortFields.Add Key:=Range("A2:A" & lr), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    ws.Sort.SortFields.Add Key:=Range("AB2:AB" & lr), SortOn:=xlSortOnValues, Order:=xlAscending, CustomOrder:="Answer Hearing,Aid of Execution,Order Back,Citation,Bond Appearance", DataOption:=xlSortNormal
    ws.Sort.SortFields.Add Key:=Range("D2:D" & lr), SortOn:=xlSortOnValues, Order:=xlAscending, CustomOrder:="Answer Hearing,Aid of Execution,Order Back,Citation,Bond Appearance", DataOption:=xlSortNormal
    ws.Sort.SortFields.Add Key:=Range("U2:U" & lr), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
    
    With ws.Sort
        .SetRange Range("A1:AB" & lr)
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    
    'Delete columns that are not needed
    ws.Columns("W:AA").Delete Shift:=xlToLeft
    ws.Columns("E:T").Delete Shift:=xlToLeft
    ws.Columns("B:C").Delete Shift:=xlToLeft
    
    'Switch Case_fmt & Type Columns
    ws.Columns("C:C").Cut
    ws.Columns("B:B").Insert
    
    'Move Docket Start Time to Column F
    ws.Columns("A:A").Cut
    ws.Columns("F:F").Insert
    Application.CutCopyMode = False
    
    'Add Notes column
    ws.Range("D1") = "Notes"
    
    'Split case_style_comp into two lines
    r = 2
    
    Do
        Rows(r + 1).Insert
    
       'Add Docket Time to new row
       Cells(r + 1, 1) = Format(Cells(r, 5), "hh:mm")
       
        'Split case sides if "vs." is found
        If InStr(1, Cells(r, 3), "vs.") > 0 Then
            Cells(r + 1, 3) = Trim(Right(Cells(r, 3), Len(Cells(r, 3)) - InStr(1, Cells(r, 3), "vs.") - 3))
            Cells(r, 3) = Trim(Left(Cells(r, 3), InStr(1, Cells(r, 3), "vs.") + 3))
        End If
       
        Cells(r + 1, 2) = Cells(r, 4)
       
        Range("A" & r).Resize(2, 4).BorderAround ColorIndex:=1, Weight:=xlThin
        Range("A" & r).Resize(2, 3).BorderAround ColorIndex:=1, Weight:=xlThin
        Range("A" & r).Resize(2, 2).BorderAround ColorIndex:=1, Weight:=xlThin
        Range("A" & r).Resize(2, 1).BorderAround ColorIndex:=1, Weight:=xlThin
        r = r + 2
    Loop While Cells(r, 1) <> ""
    
    'Clear Junk Data & Change FontSize
    Range("D2:D" & r).ClearContents 'Notes
    Range("E1:E" & lr * 3).Clear      'Time
    Columns("A:D").Font.Size = 14
    
    'Orientation
    ActiveSheet.PageSetup.Orientation = xlLandscape
    
    'Fit Columns to View
    With ws.PageSetup
        .Zoom = False
        .FitToPagesWide = 1
    End With
    
    'Autofit columns
    ws.Columns("A:C").AutoFit
    ws.Columns("D").ColumnWidth = 60

End Sub
 

krazyness

New Member
Joined
Jan 31, 2017
Messages
23
Office Version
  1. 365
Platform
  1. Windows
that works PERFECT!!!!!!!!!!!!!!!!!!!

you are amazing. thank you! hopefully that was a nice little challenge for you.

i can offer nothing more than my thank you.
 
Master Excel Bundle

Excel contains over 450 functions, with more added every year. That’s a huge number, so where should you start? Right here with this bundle.

Forum statistics

Threads
1,152,111
Messages
5,768,163
Members
425,458
Latest member
Jaspal1996

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
Top