Creating Reports in VBA using Arrays

A

anshikam

Board Regular
Joined
Aug 20, 2016
Messages
87
Hello,

I am trying to write a code to store a set of data into an array and finally generate a report in excel.
The main database has several category of rows.
My code checks for a certain value (where Col "category2 = Legal", stores specific values from corresponding row into variables.
I have been able to do store values needed successfully.
Now would like to basically have all the values in an array so this can be used to generate an excel report.
Problem I am facing is :
The value when being assigned to the array doesn't seem to work and therefore nor am i able to display in msgbox.
Attaching code below.
Any help would be greatly appreciated specially if there is an easier way to do this whole code using a different approach.
I need to generate several reports like this and generate automated emails.

Thanks in Advance
Anshika

VBA Code: 
Sub COURTDATE()
  '
  ' COURTDATE Macro
  '

  '
    Worksheets("Database").Activate
    'ActiveSheet.ListObjects("Table1").Range.AutoFilter Field:=3, Criteria1:= _
        "COURT DATE"
    'ActiveWindow.SmallScroll ToRight:=20
   
    Dim record_count As Integer
    record_count = WorksheetFunction.CountA(Range("b:b"))
    record_count = record_count + 1
   
    MsgBox "Total Records " & record_count
   
    Dim ColCat2 As Integer
    Dim ColCat3 As Integer
    Dim ColDueDate As Integer
    Dim ColCatStatus As Integer
    Dim ColCourtCases As Integer
   
    ColCat2 = WorksheetFunction.Match("CATEGORY2", ActiveWorkbook.Sheets("DATABASE").Range("1:1"), 0)
    ColCat3 = WorksheetFunction.Match("CATEGORY3", ActiveWorkbook.Sheets("DATABASE").Range("1:1"), 0)
    ColDueDate = WorksheetFunction.Match("DUE*DATE", ActiveWorkbook.Sheets("DATABASE").Range("1:1"), 0)
    ColDueDays = WorksheetFunction.Match("DUE*DAY*", ActiveWorkbook.Sheets("DATABASE").Range("1:1"), 0)
    ColCatStatus = WorksheetFunction.Match("STATUS", ActiveWorkbook.Sheets("DATABASE").Range("1:1"), 0)
    ColCourtCases = WorksheetFunction.Match("*COURT*CASE*", ActiveWorkbook.Sheets("DATABASE").Range("1:1"), 0)
   
    Dim Cat2 As String
    Dim Cat3 As String
    Dim Duedate As Date
    Dim DueDays As Integer
    Dim Status As String
    Dim Courtcase As String
   
    Dim Legalcases As Integer
    Legalcases = WorksheetFunction.CountIf(Range("b:b"), "Legal")
    MsgBox "No of Court Cases are " & Legalcases
   
   
    MsgBox record_count
    'MsgBox ColCat2 & ColCat3 & ColDueDate & ColCatStatus & ColCourtCases & Cat2 & Cat3
    Dim j As Integer
    j = 2
    Dim z As Integer
    z = 0
    Do While j <= record_count
       'Dim Value As String
       'Value = Cells(j, ColCat2).Value
       'MsgBox Value
         
       If Cells(j, ColCat2).Value = "LEGAL" Then
            'MsgBox Cells(j, ColCat2).Value & "Yes"
            Cat2 = Cells(j, ColCat2).Value
            Cat3 = Cells(j, ColCat3).Value
            Duedate = Cells(j, ColDueDate).Value
            DueDays = Cells(j, ColDueDays).Value
            Status = Cells(j, ColCatStatus).Value
            Courtcase = Cells(j, ColCourtCases).Value
            'MsgBox Cat2 & vbCrLf & Cat3 & vbCrLf & Duedate & vbCrLf & vbCrLf & Status & vbCrLf & Courtcase
            Dim MyArray(5, 49) As Variant
            'Dim dummy As String
            'dummy = Courtcase
            'MsgBox dummy
            MyArray(z, 0) = Cat2
            MyArray(z, 1) = Cat3
            MyArray(z, 2) = Duedate
            MyArray(z, 3) = DueDays
            MyArray(z, 4) = Status
            MyArray(z, 5) = Courtcase
            z = z + 1
            MsgBox "Value stored in MyArray(" & z & ",0): " & MyArray(z, 0)
        End If
        j = j + 1
    Loop
         
   
End Sub
 
Last edited by a moderator:

Excel Facts

Can Excel fill bagel flavors?
You can teach Excel a new custom list. Type the list in cells, File, Options, Advanced, Edit Custom Lists, Import, OK
Sort by date Sort by votes
Try this:

Output on Sheet2

VBA Code: 
Sub COURTDATE()
  Dim a As Variant, arr As Variant, cTexs As Variant, cCols As Variant
  Dim i As Long, j As Long, k As Long
  
  a = Sheets("Database").Range("A1", Sheets("Database").UsedRange.SpecialCells(xlCellTypeLastCell)).Value2
  cTexs = Array("CATEGORY2", "CATEGORY3", "DUE*DATE", "DUE*DAY", "STATUS", "*COURT*CASE*")
  ReDim arr(1 To UBound(a, 1), 1 To UBound(cTexs) + 1)
  ReDim cCols(0 To UBound(cTexs))
  
  For j = 0 To UBound(cTexs)
    cCols(j) = Application.Match(cTexs(j), Application.Index(a, 1), 0)
  Next
  
  For i = 1 To UBound(a, 1)
    If a(i, cCols(0)) = "LEGAL" Then
      k = k + 1
      For j = 0 To UBound(cCols)
        arr(k, j + 1) = a(i, cCols(j))
      Next
    End If
  Next
  
  Sheets("Sheet2").Range("A2").Resize(k, UBound(arr, 2)).Value = arr
End Sub
 
Upvote 0
DanteAmor said:
Try this:

Output on Sheet2

VBA Code: 
Sub COURTDATE()
  Dim a As Variant, arr As Variant, cTexs As Variant, cCols As Variant
  Dim i As Long, j As Long, k As Long
 
  a = Sheets("Database").Range("A1", Sheets("Database").UsedRange.SpecialCells(xlCellTypeLastCell)).Value2
  cTexs = Array("CATEGORY2", "CATEGORY3", "DUE*DATE", "DUE*DAY", "STATUS", "*COURT*CASE*")
  ReDim arr(1 To UBound(a, 1), 1 To UBound(cTexs) + 1)
  ReDim cCols(0 To UBound(cTexs))
 
  For j = 0 To UBound(cTexs)
    cCols(j) = Application.Match(cTexs(j), Application.Index(a, 1), 0)
  Next
 
  For i = 1 To UBound(a, 1)
    If a(i, cCols(0)) = "LEGAL" Then
      k = k + 1
      For j = 0 To UBound(cCols)
        arr(k, j + 1) = a(i, cCols(j))
      Next
    End If
  Next
 
  Sheets("Sheet2").Range("A2").Resize(k, UBound(arr, 2)).Value = arr
End Sub
Click to expand...
Hello DanteAmor,

Thanks for the code. This is certainly a better way of doing it. Will look at it however i was able to run my code effectively to storing values in the array.
Now I need to be able to :
1. Save the array value in an excel file At a specific location
2. By the name of CourtCases.xls
3. Generate an email to several ids and attach this file an email.

Any help on that would be great.

Thanks
 
Upvote 0
DanteAmor said:
Try this:

Output on Sheet2

VBA Code: 
Sub COURTDATE()
  Dim a As Variant, arr As Variant, cTexs As Variant, cCols As Variant
  Dim i As Long, j As Long, k As Long
 
  a = Sheets("Database").Range("A1", Sheets("Database").UsedRange.SpecialCells(xlCellTypeLastCell)).Value2
  cTexs = Array("CATEGORY2", "CATEGORY3", "DUE*DATE", "DUE*DAY", "STATUS", "*COURT*CASE*")
  ReDim arr(1 To UBound(a, 1), 1 To UBound(cTexs) + 1)
  ReDim cCols(0 To UBound(cTexs))
 
  For j = 0 To UBound(cTexs)
    cCols(j) = Application.Match(cTexs(j), Application.Index(a, 1), 0)
  Next
 
  For i = 1 To UBound(a, 1)
    If a(i, cCols(0)) = "LEGAL" Then
      k = k + 1
      For j = 0 To UBound(cCols)
        arr(k, j + 1) = a(i, cCols(j))
      Next
    End If
  Next
 
  Sheets("Sheet2").Range("A2").Resize(k, UBound(arr, 2)).Value = arr
End Sub
Click to expand...
This code gives me a type mismatch error

arr(k, j + 1) = a(i, cCols(j))
 
Upvote 0
My test data.
varios 28ago2020.xlsm
ABCDEFGHIJ
1ACATEGORY2CATEGORY3DUE DATEDUE DAYSTATUSGHIx COURT y CASE z
2A2B2C2D2E2F2G2H2I2J2
3A3LEGALC3D3E3F3G3H3I3J3
4A2B4C4D4E4F4G4H4I4J4
5A5LEGALC5D5E5F5G5H5I5J5
6A2B6C6D6E6F6G6H6I6J6
7A2LEGALC7D7E7F7G7H7I7J7
8A2B8C8D8E8F8G8H8I8J8
9A9LEGALC9D9E9F9G9H9I9J9
10A10B10C10D10E10F10G10H10I10J10
11A10B11C11D11E11F11G11H11I11J11
12A10B12C12D12E12F12G12H12I12J12
13A13B13C13D13E13F13G13H13I13J13
14A14B14C14D14E14F14G14H14I14J14
15A15B15C15D15E15F15G15H15I15J15
Database

Results:
varios 28ago2020.xlsm
ABCDEF
1
2LEGALC3D3E3F3J3
3LEGALC5D5E5F5J5
4LEGALC7D7E7F7J7
5LEGALC9D9E9F9J9
6
Sheet2


The error is because you have a problem in your data. Put your test data here, use the XL2BB tool, see my signature.
 
Upvote 0
DanteAmor said:
My test data.
varios 28ago2020.xlsm
ABCDEFGHIJ
1ACATEGORY2CATEGORY3DUE DATEDUE DAYSTATUSGHIx COURT y CASE z
2A2B2C2D2E2F2G2H2I2J2
3A3LEGALC3D3E3F3G3H3I3J3
4A2B4C4D4E4F4G4H4I4J4
5A5LEGALC5D5E5F5G5H5I5J5
6A2B6C6D6E6F6G6H6I6J6
7A2LEGALC7D7E7F7G7H7I7J7
8A2B8C8D8E8F8G8H8I8J8
9A9LEGALC9D9E9F9G9H9I9J9
10A10B10C10D10E10F10G10H10I10J10
11A10B11C11D11E11F11G11H11I11J11
12A10B12C12D12E12F12G12H12I12J12
13A13B13C13D13E13F13G13H13I13J13
14A14B14C14D14E14F14G14H14I14J14
15A15B15C15D15E15F15G15H15I15J15
Database

Results:
varios 28ago2020.xlsm
ABCDEF
1
2LEGALC3D3E3F3J3
3LEGALC5D5E5F5J5
4LEGALC7D7E7F7J7
5LEGALC9D9E9F9J9
6
Sheet2


The error is because you have a problem in your data. Put your test data here, use the XL2BB tool, see my signature.
Click to expand...
Thanks DanteAmor,

My code is now working ...a different approach though. Will take a look at your code and my data gain since it seems super concise. (Have downloaded the Excel Add-In and added however for some reason don't see the option on my Excel Toolbar).

Can you help me with the last portion of my code listed below:
1. Save the file ("CourtCases31082020) at a specific location : "F:/Corporate/Anshika/DueDates/Sent"
2. Paste MyArray data on the sheet1
3. Rename the sheet to CourtCasesReport.
4. Save the file.
5. Create an email to attach the file and send.

PS: Code listed below for creating a file with a specific filename

Dim report As String
Dim a As Date
a = Date
report = "CourtCases" & a & ".xls"
MsgBox report
Workbooks.Add.SaveAs Filename:=report
Workbooks(report).Activate
 
Upvote 0
You must log in or register to reply here.

Similar threads

M
  • Question
I need help with this code to modify the data into a table using Userform for VBA Excel (I want to do the range unlimited instead to do C7:C80000
Replies
5
Views
470
Dan_W
D
P
  • Solved
VBA code keeps jumping back to start of Sub as soon as it completes first iteration in the nested loop
Replies
2
Views
577
Pardeep Singh
P
B
  • Solved
How to write WHERE clause when importing data from MySQL using VBA
Replies
4
Views
990
Brutusar
B
P
  • Question
Freeze on specific sheet during macro execution and loop through each sheets containing a specific name
Replies
5
Views
709
BSALV
BSALV
P
  • Question
Conflicting Codes Help Please
Replies
2
Views
476
pure vito
P

Forum statistics

Threads
1,214,976
Messages
6,122,541
Members
449,089
Latest member
davidcom

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