Small updates to VBA Macro code

K

krazyness

New Member
Joined
Jan 31, 2017
Messages
26
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:
Sort by date Sort by votes
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
 
Upvote 0

Excel Facts

Copy PDF to Excel
Select data in PDF. Paste to Microsoft Word. Copy from Word and paste to Excel.
close!

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

1596661493972.png
 
Upvote 0
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.
 
Upvote 0
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!
 
Upvote 0
krazyness said:
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.
Click to expand...

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?
 
Upvote 0
Caleeco said:
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?
Click to expand...
correct. it brought the input box.. i typed the date. when printed... it does not appear.
 
Upvote 0
krazyness said:
correct. it brought the input box.. i typed the date. when printed... it does not appear.
Click to expand...

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
 
Upvote 0
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
 
Upvote 0
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.
 
Upvote 0
You must log in or register to reply here.

Similar threads

O
  • Solved
VBA: Deleting Visible rows using Auto Filter; Excluding Header
Replies
4
Views
375
mumps
mumps
B
  • Question
How to Create a Loop to ignore BLANK CELLS
Replies
3
Views
231
Alex Blakenburg
A
Dazzawm
  • Question
Change Recorded Range To Used Range.
2
Replies
12
Views
364
Dazzawm
Dazzawm
C
  • Question
How to get my macro to stop at the last recognized line
Replies
6
Views
205
Coco1
C
C
  • Question
Daily Run data (copy data in loop by daily in worksheet)
Replies
3
Views
156
dermie_72
D

Forum statistics

Threads
1,214,804
Messages
6,121,652
Members
449,045
Latest member
Marcus05

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