Align excel data format to use bulk pdf free software

bamfan285

New Member
Joined
Feb 3, 2022
Messages
6
Office Version
  1. 2021
  2. 2016
Platform
  1. Windows
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 NumberPersons NameCubicle
RandomSerial1Alice Andrews1
RandomSerial2Alice Andrews1
RandomSerial3Bob Bones2
RandomSerial4Bob Bones2
RandomSerial5Charles Carter3
RandomSerial6Charles Carter3



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
RandomSerial1Alice Andrews1RandomSerial2Alice Andrews1
RandomSerial3Bob Bones2RandomSerial4Bob Bones2
RandomSerial5Charles Carter3RandomSerial6Charles Carter3
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:
VBA 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

Well-known Member
Joined
Nov 1, 2008
Messages
4,004
Office Version
  1. 365
Platform
  1. Windows
  2. MacOS
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?
 

Excel Facts

How to calculate loan payments in Excel?
Use the PMT function: =PMT(5%/12,60,-25000) is for a $25,000 loan, 5% annual interest, 60 month loan.

sijpie

Well-known Member
Joined
Nov 1, 2008
Messages
4,004
Office Version
  1. 365
Platform
  1. Windows
  2. MacOS
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.

VBA Code:
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

Well-known Member
Joined
Nov 1, 2008
Messages
4,004
Office Version
  1. 365
Platform
  1. Windows
  2. MacOS
The template sheet
 

Attachments

  • Screenshot 2022-02-15 153314.png
    Screenshot 2022-02-15 153314.png
    42.4 KB · Views: 4

sijpie

Well-known Member
Joined
Nov 1, 2008
Messages
4,004
Office Version
  1. 365
Platform
  1. Windows
  2. MacOS
In the code, check the remarks starting with <<<<<
 

sijpie

Well-known Member
Joined
Nov 1, 2008
Messages
4,004
Office Version
  1. 365
Platform
  1. Windows
  2. MacOS
Once the format and contents are OK, I will add the print to pdf for each sheet
 

bamfan285

New Member
Joined
Feb 3, 2022
Messages
6
Office Version
  1. 2021
  2. 2016
Platform
  1. Windows
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

Well-known Member
Joined
Nov 1, 2008
Messages
4,004
Office Version
  1. 365
Platform
  1. Windows
  2. MacOS
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

Well-known Member
Joined
Nov 1, 2008
Messages
4,004
Office Version
  1. 365
Platform
  1. Windows
  2. MacOS
OK, I have set up the input table as follows:
HRPartNumberSerial NumberModelDescBldgRoomWhoCubicleIssue DateMake (mfg)OrganisationEquip CustodianCustodian Account
KF35-HH67RandomSerial1Phone
856​
104​
Alice Andrews
1​
22/02/2022​
AppleXYZMungo Jerry
34567​
KF35-HH68RandomSerial2Laptop
856​
104​
Alice Andrews
1​
22/02/2022​
AcerXYZMungo Jerry
34567​
KF48-PK69RandomSerial3Monitor
856​
104​
Bob Bones
2​
15/01/2022​
DellXYZMungo Jerry
34567​
KF35-HH70RandomSerial4PC
856​
104​
Bob Bones
2​
15/01/2022​
HPXYZMungo Jerry
34567​
KF48-PK71RandomSerial5Laptop
856​
104​
Charles Carter
3​
06/02/2022​
AcerXYZMungo Jerry
34567​
KF35-HH72RandomSerial6Monitor
856​
104​
Charles Carter
3​
06/02/2022​
DellXYZMungo Jerry
34567​
KF35-HH73RandomSerial11PC
856​
104​
Alice Andrews
1​
22/02/2022​
HPXYZMungo Jerry
34567​
KF48-PK74RandomSerial21Phone
856​
104​
Alice Andrews
1​
22/02/2022​
AppleXYZMungo Jerry
34567​
KF35-HH75RandomSerial31Laptop
856​
104​
Bob Bones
2​
15/01/2022​
AcerXYZMungo Jerry
34567​
KF35-HH76RandomSerial41Monitor
856​
104​
Bob Bones
2​
15/01/2022​
DellXYZMungo Jerry
34567​
KF48-PK77RandomSerial51PC
856​
104​
Charles Carter
3​
06/02/2022​
HPXYZMungo Jerry
34567​
KF35-HH78RandomSerial211Monitor
856​
104​
Alice Andrews
1​
22/02/2022​
DellXYZMungo 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

VBA Code:
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
 

Forum statistics

Threads
1,171,861
Messages
5,877,946
Members
433,301
Latest member
MJ_Mac

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