Align excel data format to use bulk pdf free software

[bamfan285]

Align excel data format to use bulk pdf free software

I track equipment in our office and who and what cubicle its assigned to in excel I attempting to automate creating a pdf for each person with their equipment.

This information needs to go into a pdf for each person, but a person will have multiple pieces of equipment (A person can have 3 to 8 pieces of equipment).

For the final product, I would have a pdf which list the equipment for that person. and Have a pdf for each person.

Bulk PDf can do the pdf side if I can align the data in the format needed.

Desired format:
Copy from original sheet to a sheet where a persons equipment is on one row.
Alice on row 1
Bob on row 2, etc.

Sample Data:

Equipment Serial Number	Persons Name	Cubicle
RandomSerial1	Alice Andrews	1
RandomSerial2	Alice Andrews	1
RandomSerial3	Bob Bones	2
RandomSerial4	Bob Bones	2
RandomSerial5	Charles Carter	3
RandomSerial6	Charles Carter	3

Desired New Sheet Example:
Row "1" Title row (Denotes Columns Letters):

(A)Equipment Serial Number	(B)Persons Name	(C)Cubicle	(D)Equipment Serial Number	(E)Persons Name	(F)Cubicle
RandomSerial1	Alice Andrews	1	RandomSerial2	Alice Andrews	1
RandomSerial3	Bob Bones	2	RandomSerial4	Bob Bones	2
RandomSerial5	Charles Carter	3	RandomSerial6	Charles Carter	3

Row "2" (will contain all of Alices Equipment):
Row "3" (will contain all of Bobs Equipment):
etc.

Its not important that information repeats in columns in the new sheet as the bulk pdf software can handle this, I just needs a singles person equipment on 1 row, a different persons equipment on row 2, etc.
Copying the row seems easier than extracting the data needed (since the bulk pdf software handles it).

Im attempting to modify this array which put everyone on a new sheets in a similar format (each equipment has its own row, as opposed to each person having a row with all their equipment). I dont know vba well enough to modify this code.
I need to compare the names and if they are the same, copy the row to a sheet such that a user is on a single row, all users on the same sheet.

Bulk PDF creates pdf based on rows, and fills the data based on columns.


Code:

Sub parse_data()
    Dim lr As Long
    Dim ws As Worksheet
    Dim vcol, i As Integer
    Dim icol As Long
    Dim myarr As Variant
    Dim title As String
    Dim titlerow As Integer

    'This macro splits data into multiple worksheets based on the variables on a column found in Excel.
    'An InputBox asks you which columns you'd like to filter by, and it just creates these worksheets.

    Application.ScreenUpdating = False
    vcol = Application.InputBox(prompt:="Which column would you like to filter by?", title:="Filter column", Default:="3", Type:=1)
    Set ws = ActiveSheet
    lr = ws.Cells(ws.Rows.Count, vcol).End(xlUp).Row
    title = "A1"
    titlerow = ws.Range(title).Cells(1).Row
    icol = ws.Columns.Count
    ws.Cells(1, icol) = "Unique"
    For i = 2 To lr
        On Error Resume Next
        If ws.Cells(i, vcol) <> "" And Application.WorksheetFunction.Match(ws.Cells(i, vcol), ws.Columns(icol), 0) = 0 Then
            ws.Cells(ws.Rows.Count, icol).End(xlUp).Offset(1) = ws.Cells(i, vcol)
        End If
    Next

    myarr = Application.WorksheetFunction.Transpose(ws.Columns(icol).SpecialCells(xlCellTypeConstants))
    ws.Columns(icol).Clear

    For i = 2 To UBound(myarr)
        ws.Range(title).AutoFilter field:=vcol, Criteria1:=myarr(i) & ""
        If Not Evaluate("=ISREF('" & myarr(i) & "'!A1)") Then
            Sheets.Add(after:=Worksheets(Worksheets.Count)).Name = myarr(i) & ""
        Else
            Sheets(myarr(i) & "").Move after:=Worksheets(Worksheets.Count)
        End If
        ws.Range("A" & titlerow & ":A" & lr).EntireRow.Copy Sheets(myarr(i) & "").Range("A1")
        'Sheets(myarr(i) & "").Columns.AutoFit
    Next

    ws.AutoFilterMode = False
    ws.Activate
    Application.ScreenUpdating = True
End Sub

 

[sijpie]

I also notice that the mfg (I assume manufacturer) of the equip is not in the input list.
How do you want to add this?

 

[sijpie]

Make sure you read and answer the previous TWO posts.

In the meantime I have set up the following:
In the spreadsheet running the macro I have created a template sheet called "Template'. This has all the required fields for the pdf output. The macro will make a copy of this template and fill it out for each person.

The template looks like attached.

The macro to generate sheets for each user follows here. Note that there are a number of fields in the upper part of the form that ned to be filled out, but for that I need your answer to the previous two posts.

Option Explicit

Sub TransferToEquipPerPerson()
'Transfer equipment per user to copy of template sheet as per format Form AFMC IMT31 20051216, V2 _
 starting from cell A1
 
    Dim lRi As Long, lCi As Long, lRo As Long, lCo As Long, UBi As Long, UB1o As Long, UB2o As Long
    Dim vIn As Variant, vOut As Variant
    Dim wsInput As Worksheet, wsOut As Worksheet
    Dim sName As String, sCub As String, sKey As String
    Dim bDone As Boolean
    Dim colNames As Collection
    Dim iCC As Integer, j
    
    Set wsInput = Sheets("Sheet1") '<<<<<< Adjust name to the sheet with the table of input data (as per your 'sample data')
    '' Input Table layout
    'HR  PartNumber  SerialNumber   ModelDesc   Bldg    Room    Who   Cubicle
    ' 1      2            3              4         5       6      7       8
    
    vIn = wsInput.Range("A1").CurrentRegion.Value '<<<<<< Adjust cell to left top corner of the table. This assumes there ar no totally empty rows or columns in yur table
    UBi = UBound(vIn, 1)    'number of rows in input

    If UBi = 1 Then
        MsgBox "No data to process", vbInformation + vbOKOnly, "Empty input table"
        Exit Sub
    End If
    
    'Use a collection to get the unique names
    Set colNames = New Collection
    
    On Error Resume Next        ' adding a dubplicate name to a collection will create an error. We want to ignore this. The name does not get added.
    For lRi = 2 To UBi          'Skip header row
        sName = vIn(lRi, 7) & "_" & vIn(lRi, 5) & "_" & vIn(lRi, 6) & "_" & vIn(lRi, 8)
        sKey = sName            ' People can have same name, so add location as extra identifier to key
        colNames.Add sName, sKey
    Next lRi
    On Error GoTo 0             'reset to default behaviour
    
    iCC = colNames.Count
    
    Application.ScreenUpdating = False
    For j = 1 To iCC
    ' For each user generate report from template and fill out equipment details
        sName = Left(colNames(j), InStr(1, colNames(j), "_") - 1)
        With Sheets("Template")
            .Visible = xlSheetVisible
            .Copy after:=Sheets(Sheets.Count)
            .Visible = xlSheetHidden
        End With
        Set wsOut = ActiveSheet
        wsOut.Name = j & ". " & sName
        
        'Fill out the headers
        With wsOut
            .Range("A7") = sName
        End With
        
        '' Create and clear the output table for the equip list
        'PartNumber IssueDate  ReturnDate MFG Type  Serial  Building  Location
        '     1        2            3      4    5     6        7         8

        ReDim vOut(1 To 8, 1 To 8)  '8 rows by 8 columns
        UB1o = UBound(vOut, 1): UB2o = UBound(vOut, 2)  ' get the size of the output array. In case you change the size in line above, this will always be correct
        
        'Now go through the input table for each name in the collection and add the equipment serial numbers
        lRo = 1
        For lRi = 2 To UBi                  'skip header row of input table
            If vIn(lRi, 7) Like sName Then  'found line with same name
                'check if same location (could be two employees with same name)
                If sName & "_" & vIn(lRi, 5) & "_" & vIn(lRi, 6) & "_" & vIn(lRi, 8) Like colNames(j) Then
                    If lRo > UB1o Then  'More than 8 items - need to increase the output array number of rows
                        vOut = RedimArrayRows(vOut, 1)
                        UB1o = UBound(vOut, 1)
                        ' also increase rows in form
                        wsOut.Rows(16).EntireRow.Insert
                    End If
                    'Part number
                    vOut(lRo, 1) = vIn(lRi, 2)
                    ' Issue date
                    vOut(lRo, 2) = Format(Now, "yy/mm/dd")    '<<<<< the format of dat can be modified here
                    'MFG
                    vOut(lRo, 4) = ""
                    'Type
                    vOut(lRo, 5) = vIn(lRi, 4)
                    'Serial Nr
                    vOut(lRo, 6) = vIn(lRi, 3)
                    'Building
                    vOut(lRo, 7) = vIn(lRi, 5)
                    'add location & cubicle nr to row
                    vOut(lRo, 8) = vIn(lRi, 6) & " / " & vIn(lRi, 8)
                    'increase lRo for next row in output array
                    lRo = lRo + 1
                End If
            End If
        Next lRi
        'dump output into form
        wsOut.Range("A9").Resize(UB1o, UB2o).Value = vOut
        
    Next j
    Application.ScreenUpdating = True
End Sub

Function RedimArrayRows(vArrIn, IncrRow As Integer) As Variant()
' Function to add rows to array and keep contents of array
    Dim vOut As Variant
    Dim UB1 As Long, UB2 As Long, LB1 As Integer, LB2 As Integer
    
    If Not IsArray(vArrIn) Then Exit Function
    
    UB1 = UBound(vArrIn, 1): UB2 = UBound(vArrIn, 2)
    LB1 = LBound(vArrIn, 1): LB2 = LBound(vArrIn, 2)
    
    vOut = Application.WorksheetFunction.Transpose(vArrIn)
    ReDim Preserve vOut(LB2 To UB2, LB1 To UB1 + IncrRow)
    
    RedimArrayRows = Application.WorksheetFunction.Transpose(vOut)

End Function

 

[sijpie]

The template sheet

 

[sijpie]

In the code, check the remarks starting with <<<<<

 

[sijpie]

Once the format and contents are OK, I will add the print to pdf for each sheet

 

[bamfan285]

Is that the person who has compiled the data list? ie, is the custodian the same for all people on this list?

Yes, Equipment Custodian is the same for all people (and controls the data list), but it changes every year.

Is the organization the same for all people on the list?

Organization is the same for all people, but it changes every year or two.

What about the issue date? Can I ask, in the macro, to provide a date and apply that to all equipment?

Issue date varies from person to person.

I also notice that the mfg (I assume manufacturer) of the equip is not in the input list.
How do you want to add this?

I have Mfg on another sheet.

Can we add all four of these inputs as different columns? I can enter them from the "Master Data Sheet", they would then be available for copy to your template.
We could just use the next available columns, if that the easiest way to add these inputs.

 

[sijpie]

Issue date and mfg as an extra column in the master data, organisation and custodian details somewhere (fixed) on the sheet, or I can ask for them in the macro. Whatever you prefer

 

[sijpie]

OK, I have set up the input table as follows:

HR

PartNumber

Serial Number

ModelDesc

Bldg

Room

Who

Cubicle

Issue Date

Make (mfg)

Organisation

Equip Custodian

Custodian Account

KF35-HH67

RandomSerial1

Phone

856​

104​

Alice Andrews

1​

22/02/2022​

Apple

XYZ

Mungo Jerry

34567​

KF35-HH68

RandomSerial2

Laptop

856​

104​

Alice Andrews

1​

22/02/2022​

Acer

XYZ

Mungo Jerry

34567​

KF48-PK69

RandomSerial3

Monitor

856​

104​

Bob Bones

2​

15/01/2022​

Dell

XYZ

Mungo Jerry

34567​

KF35-HH70

RandomSerial4

PC

856​

104​

Bob Bones

2​

15/01/2022​

HP

XYZ

Mungo Jerry

34567​

KF48-PK71

RandomSerial5

Laptop

856​

104​

Charles Carter

3​

06/02/2022​

Acer

XYZ

Mungo Jerry

34567​

KF35-HH72

RandomSerial6

Monitor

856​

104​

Charles Carter

3​

06/02/2022​

Dell

XYZ

Mungo Jerry

34567​

KF35-HH73

RandomSerial11

PC

856​

104​

Alice Andrews

1​

22/02/2022​

HP

XYZ

Mungo Jerry

34567​

KF48-PK74

RandomSerial21

Phone

856​

104​

Alice Andrews

1​

22/02/2022​

Apple

XYZ

Mungo Jerry

34567​

KF35-HH75

RandomSerial31

Laptop

856​

104​

Bob Bones

2​

15/01/2022​

Acer

XYZ

Mungo Jerry

34567​

KF35-HH76

RandomSerial41

Monitor

856​

104​

Bob Bones

2​

15/01/2022​

Dell

XYZ

Mungo Jerry

34567​

KF48-PK77

RandomSerial51

PC

856​

104​

Charles Carter

3​

06/02/2022​

HP

XYZ

Mungo Jerry

34567​

KF35-HH78

RandomSerial211

Monitor

856​

104​

Alice Andrews

1​

22/02/2022​

Dell

XYZ

Mungo Jerry

34567​

>>>> When you have created your template sheet, (see a few posts earlier) go to the file / print menu and set it up for A4 (or Letter, whatever) AND scaling: print on one page.

The macro will hide the template sheet. If you need to make changes, then you can unhide it by right clicking on a sheet tab and selecting Unhide...

The following two macros will create the sheets for each user and print to PDF. I have separated them as you may need to adjust the contents before printing. But if that is not necessary then uncomment the last line of the first macro to run the printing automatically.

>>>> As before: Read all the comments starting with >>>> carefully and adjust if necessary

Option Explicit

Sub TransferToEquipPerPerson()
'Transfer equipment per user to copy of template sheet as per format Form AFMC IMT31 20051216, V2 _
 starting from cell A1
 
    Dim lRi As Long, lCi As Long, lRo As Long, lCo As Long, UBi As Long, UB1o As Long, UB2o As Long
    Dim vIn As Variant, vOut As Variant
    Dim wsInput As Worksheet, wsOut As Worksheet
    Dim sName As String, sCub As String, sKey As String
    Dim bDone As Boolean
    Dim colNames As Collection
    Dim iCC As Integer, j
    
    Set wsInput = Sheets("Sheet1") '<<<<<< Adjust name to the sheet with the table of input data (as per your 'sample data')
    '' Input Table layout
    'HR  PartNumber  SerialNumber   ModelDesc   Bldg    Room    Who   Cubicle IssueDate  Make(mfg)  Organisation    EquipCustodian CustodianAccount
    ' 1      2            3              4         5       6      7       8       9         10          11                  12          13
    
    vIn = wsInput.Range("A1").CurrentRegion.Value '<<<<<< Adjust cell to left top corner of the table. This assumes there ar no totally empty rows or columns in yur table
    UBi = UBound(vIn, 1)    'number of rows in input

    If UBi = 1 Then
        MsgBox "No data to process", vbInformation + vbOKOnly, "Empty input table"
        Exit Sub
    End If
    
    'Use a collection to get the unique names
    Set colNames = New Collection
    
    On Error Resume Next        ' adding a dubplicate name to a collection will create an error. We want to ignore this. The name does not get added.
    For lRi = 2 To UBi          'Skip header row
        sName = vIn(lRi, 7) & "_" & vIn(lRi, 5) & "_" & vIn(lRi, 6) & "_" & vIn(lRi, 8)
        sKey = sName            ' People can have same name, so add location as extra identifier to key
        colNames.Add sName, sKey
    Next lRi
    On Error GoTo 0             'reset to default behaviour
    
    iCC = colNames.Count
    
    Application.ScreenUpdating = False
    For j = 1 To iCC
    ' For each user generate report from template and fill out equipment details
        sName = Left(colNames(j), InStr(1, colNames(j), "_") - 1)
        With Sheets("Template")
            .Visible = xlSheetVisible
            .Copy after:=Sheets(Sheets.Count)
            .Visible = xlSheetHidden
        End With
        Set wsOut = ActiveSheet
        wsOut.Name = j & ". " & sName
        
        'Fill out the headers, organisation, custodian same for all
        With wsOut
            .Range("A7") = sName
            .Range("A3") = vIn(2, 11)
            .Range("A5") = vIn(2, 13)
            .Range("C5") = vIn(2, 12)
        End With
        
        '' Create and clear the output table for the equip list
        'PartNumber IssueDate  ReturnDate MFG Type  Serial  Building  Location
        '     1        2            3      4    5     6        7         8

        ReDim vOut(1 To 8, 1 To 8)  '8 rows by 8 columns
        UB1o = UBound(vOut, 1): UB2o = UBound(vOut, 2)  ' get the size of the output array. In case you change the size in line above, this will always be correct
        
        'Now go through the input table for each name in the collection and add the equipment serial numbers
        lRo = 1
        For lRi = 2 To UBi                  'skip header row of input table
            If vIn(lRi, 7) Like sName Then  'found line with same name
                'check if same location (could be two employees with same name)
                If sName & "_" & vIn(lRi, 5) & "_" & vIn(lRi, 6) & "_" & vIn(lRi, 8) Like colNames(j) Then
                    If lRo > UB1o Then  'More than 8 items - need to increase the output array number of rows
                        vOut = RedimArrayRows(vOut, 1)
                        UB1o = UBound(vOut, 1)
                        ' also increase rows in form
                        wsOut.Rows(16).EntireRow.Insert
                    End If
                    'Part number
                    vOut(lRo, 1) = vIn(lRi, 2)
                    ' Issue date
                    vOut(lRo, 2) = Format(vIn(lRi, 9), "yy/mm/dd")    '<<<<< the format of date can be modified here
                    'MFG
                    vOut(lRo, 4) = vIn(lRi, 10)
                    'Type
                    vOut(lRo, 5) = vIn(lRi, 4)
                    'Serial Nr
                    vOut(lRo, 6) = vIn(lRi, 3)
                    'Building
                    vOut(lRo, 7) = vIn(lRi, 5)
                    'add location & cubicle nr to row
                    vOut(lRo, 8) = vIn(lRi, 6) & " / " & vIn(lRi, 8)
                    'increase lRo for next row in output array
                    lRo = lRo + 1
                End If
            End If
        Next lRi
        'dump output into form
        wsOut.Range("A9").Resize(UB1o, UB2o).Value = vOut
        
    Next j
    wsInput.Activate
    Application.ScreenUpdating = True
    ' >>>> Uncomment the line below to run the export to PDF automatically. _
     If you need to adjust the sheets before export, then leave the line commented
'    PrintPDFs
End Sub

Sub PrintPDFs()
    Dim wsWS As Worksheet
    Dim sN As String, sI As String, sPath As String, sFN As String
    Const sFORW As String = "/", sBACK As String = "\"
    
    '======
    ' store the path for the pdf's - <<<<< the code below will use the excel workbook path
    sPath = ThisWorkbook.Path
    If sPath Like "*" & sFORW & "*" Then
        sPath = sPath & sFORW
    Else
        sPath = sPath & sBACK
    End If
    ' <<<<< If you want to use a different path, then comment out the code above and remove comment from line below
    'sPath = "C:\MyPath\         'Make sure path ends with path separator (\ or / depending on server)"
    '======
    
    
    For Each wsWS In Sheets
        sN = wsWS.Name
        If sN Like "*.*" Then
            sI = Left(sN, InStr(sN, ".") - 1)
            If IsNumeric(sI) Then
                wsWS.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
                    sPath & sN & ".pdf", Quality:=xlQualityStandard, _
                    IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:= _
                    False
            End If
        End If
    Next wsWS
End Sub

Function RedimArrayRows(vArrIn, IncrRow As Integer) As Variant()
' Function to add rows to array and keep contents of array
    Dim vOut As Variant
    Dim UB1 As Long, UB2 As Long, LB1 As Integer, LB2 As Integer
    
    If Not IsArray(vArrIn) Then Exit Function
    
    UB1 = UBound(vArrIn, 1): UB2 = UBound(vArrIn, 2)
    LB1 = LBound(vArrIn, 1): LB2 = LBound(vArrIn, 2)
    
    vOut = Application.WorksheetFunction.Transpose(vArrIn)
    ReDim Preserve vOut(LB2 To UB2, LB1 To UB1 + IncrRow)
    
    RedimArrayRows = Application.WorksheetFunction.Transpose(vOut)

End Function