Extract Data from Sheet Formatted for Printing

[dhewett]

Our company use Excel for our sales templates. It's a workbook with multiple tabs that roll into a formatted sheet that's saved as a PDF proposal.

Trying to create a process to extract the data from the templates without manually copying and pasting into a master project sheet I use for tracking.

Obviously Power Query doesn't like this because the data is not formatted as a table. I don't need all data - about 20 different cells on one sheet.

Any ideas on how to streamline this process?

 

[frank_AL]

Are the fields shown in the screenshot all of the fields you want to capture?
What is the name of the Worksheet where these fields are located and is that consistent across all proposals?
Are all the files located in one folder and do you want the process to run against all files in that folder?

 

[dhewett]

Are the fields shown in the screenshot all of the fields you want to capture?
What is the name of the Worksheet where these fields are located and is that consistent across all proposals?
Are all the files located in one folder and do you want the process to run against all files in that folder?

Yes. This sheet is “Proposal”. It is always labeled that. I would move a copy into my folder.

 

[frank_AL]

Before I get too far in writing code here is how I have mapped those fields from the Proposal worksheet to a database type file where you will be copying the data to. If my mapping is not correct please post the correct sequencing.

 

[frank_AL]

Also, what is the name of the Worksheet in the file you will be copying data to?

 

[frank_AL]

Here is a sample of output:

 

[frank_AL]

Here is the code:
Let me know if this works for you
This code assumes the code resides in the 'Copy to' Workbook. Let me know if it needs to be in a standalone file.

Option Explicit

Sub CopyProposal()

Dim cfwb As Workbook
Dim ctwb As Workbook
Dim cfws As Worksheet
Dim ctws As Worksheet
Dim i As Integer
Dim answer1 As Integer
Dim ctnr As Integer
Dim ProposalFN As String
Dim cncl As Boolean
Dim MoreFiles As Boolean


'   You can set the program to look in a specific folder to open a file using the ChDir command.
'   Example of CHDIR:  ChDir "C:\Users\test\Proposals\Prosal Files"

cncl = False
MoreFiles = True

'   Loop Code for one or more Proposal Files
Do Until MoreFiles = False

'   Choose Proposal File to Open and define Workbook and Worksheet variables
    ProposalFN = Application.GetOpenFilename _
    (Title:="Please choose the Proposal file to Open", _
    FileFilter:="Excel Files *.xls* (*.xls*),")
    
    If ProposalFN = "False" Then
        cncl = True
       MsgBox "No Proposal file was specified." & vbCrLf & vbCrLf & "Code Execution will be Aborted.", , vbExclamation
       GoTo CheckCncl
    Else
       Set cfwb = Workbooks.Open(ProposalFN)
       Set cfws = cfwb.Sheets("Proposal")
       Set ctwb = ThisWorkbook
       Set ctws = ctwb.Sheets("All Proposals")
    End If
    
    ctnr = ctws.Cells(ctws.Rows.Count, "A").End(xlUp).Row + 1
    
    '   Copy Data
    ctws.Cells(ctnr, "A").Value = cfws.Range("E6")  ' Project
    ctws.Cells(ctnr, "B").Value = cfws.Range("K3")  ' Contact
    ctws.Cells(ctnr, "C").Value = cfws.Range("K4")  ' Email
    ctws.Cells(ctnr, "D").Value = cfws.Range("K5")  ' Direct
    ctws.Cells(ctnr, "E").Value = cfws.Range("K6")  ' Office
    ctws.Cells(ctnr, "F").Value = cfws.Range("K8")  ' Manfacturing Location
    ctws.Cells(ctnr, "G").Value = cfws.Range("C9")  ' Customer
    ctws.Cells(ctnr, "H").Value = cfws.Range("C10")  ' Primary Contact
    ctws.Cells(ctnr, "I").Value = cfws.Range("C11")  ' Phone
    ctws.Cells(ctnr, "J").Value = cfws.Range("C12")  ' Email
    ctws.Cells(ctnr, "K").Value = cfws.Range("C14")  ' Project Address
    ctws.Cells(ctnr, "L").Value = cfws.Range("G9")  ' Quote
    ctws.Cells(ctnr, "M").Value = cfws.Range("G10")  ' Version
    ctws.Cells(ctnr, "N").Value = cfws.Range("G11")  ' Quote Date
    ctws.Cells(ctnr, "O").Value = cfws.Range("G12")  ' Valid Until
    ctws.Cells(ctnr, "P").Value = cfws.Range("G14")  ' Deposit
    ctws.Cells(ctnr, "Q").Value = cfws.Range("K10")  ' Plan Description
    ctws.Cells(ctnr, "R").Value = cfws.Range("K11")  ' Plan Set Date
    ctws.Cells(ctnr, "S").Value = cfws.Range("K12")  ' Addendum(s)
    
'   Close Proposal File
    cfwb.Close SaveChanges:=False
    
    '   Do you want to process addition files?
    answer1 = MsgBox("Add another Proposal File?", vbYesNo)
    Select Case answer1
        Case vbNo
            MoreFiles = False
    End Select
Loop  ' Until MoreFiles = False

CheckCncl:
ThisWorkbook.Activate

End Sub

 

[dhewett]

Here is the code:
Let me know if this works for you
This code assumes the code resides in the 'Copy to' Workbook. Let me know if it needs to be in a standalone file.

Option Explicit

Sub CopyProposal()

Dim cfwb As Workbook
Dim ctwb As Workbook
Dim cfws As Worksheet
Dim ctws As Worksheet
Dim i As Integer
Dim answer1 As Integer
Dim ctnr As Integer
Dim ProposalFN As String
Dim cncl As Boolean
Dim MoreFiles As Boolean


'   You can set the program to look in a specific folder to open a file using the ChDir command.
'   Example of CHDIR:  ChDir "C:\Users\test\Proposals\Prosal Files"

cncl = False
MoreFiles = True

'   Loop Code for one or more Proposal Files
Do Until MoreFiles = False

'   Choose Proposal File to Open and define Workbook and Worksheet variables
    ProposalFN = Application.GetOpenFilename _
    (Title:="Please choose the Proposal file to Open", _
    FileFilter:="Excel Files *.xls* (*.xls*),")
   
    If ProposalFN = "False" Then
        cncl = True
       MsgBox "No Proposal file was specified." & vbCrLf & vbCrLf & "Code Execution will be Aborted.", , vbExclamation
       GoTo CheckCncl
    Else
       Set cfwb = Workbooks.Open(ProposalFN)
       Set cfws = cfwb.Sheets("Proposal")
       Set ctwb = ThisWorkbook
       Set ctws = ctwb.Sheets("All Proposals")
    End If
   
    ctnr = ctws.Cells(ctws.Rows.Count, "A").End(xlUp).Row + 1
   
    '   Copy Data
    ctws.Cells(ctnr, "A").Value = cfws.Range("E6")  ' Project
    ctws.Cells(ctnr, "B").Value = cfws.Range("K3")  ' Contact
    ctws.Cells(ctnr, "C").Value = cfws.Range("K4")  ' Email
    ctws.Cells(ctnr, "D").Value = cfws.Range("K5")  ' Direct
    ctws.Cells(ctnr, "E").Value = cfws.Range("K6")  ' Office
    ctws.Cells(ctnr, "F").Value = cfws.Range("K8")  ' Manfacturing Location
    ctws.Cells(ctnr, "G").Value = cfws.Range("C9")  ' Customer
    ctws.Cells(ctnr, "H").Value = cfws.Range("C10")  ' Primary Contact
    ctws.Cells(ctnr, "I").Value = cfws.Range("C11")  ' Phone
    ctws.Cells(ctnr, "J").Value = cfws.Range("C12")  ' Email
    ctws.Cells(ctnr, "K").Value = cfws.Range("C14")  ' Project Address
    ctws.Cells(ctnr, "L").Value = cfws.Range("G9")  ' Quote
    ctws.Cells(ctnr, "M").Value = cfws.Range("G10")  ' Version
    ctws.Cells(ctnr, "N").Value = cfws.Range("G11")  ' Quote Date
    ctws.Cells(ctnr, "O").Value = cfws.Range("G12")  ' Valid Until
    ctws.Cells(ctnr, "P").Value = cfws.Range("G14")  ' Deposit
    ctws.Cells(ctnr, "Q").Value = cfws.Range("K10")  ' Plan Description
    ctws.Cells(ctnr, "R").Value = cfws.Range("K11")  ' Plan Set Date
    ctws.Cells(ctnr, "S").Value = cfws.Range("K12")  ' Addendum(s)
   
'   Close Proposal File
    cfwb.Close SaveChanges:=False
   
    '   Do you want to process addition files?
    answer1 = MsgBox("Add another Proposal File?", vbYesNo)
    Select Case answer1
        Case vbNo
            MoreFiles = False
    End Select
Loop  ' Until MoreFiles = False

CheckCncl:
ThisWorkbook.Activate

End Sub

Thank you! Going to put this to test tomorrow.