Extract Data from Sheet Formatted for Printing

D

dhewett

New Member
Joined
Nov 22, 2023
Messages
9
Office Version
  1. 365
Platform
  1. Windows
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?

1705704698968.png
 

Excel Facts

How can you automate Excel?
Press Alt+F11 from Windows Excel to open the Visual Basic for Applications (VBA) editor.
Sort by date Sort by votes
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?
 
Upvote 0
frank_AL said:
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?
Click to expand...
Yes. This sheet is “Proposal”. It is always labeled that. I would move a copy into my folder.
 
Upvote 0
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.
1705851709170.png
 
Upvote 0
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.

VBA Code: 
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
 
Upvote 0
frank_AL said:
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.

VBA Code: 
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
Click to expand...
Thank you! Going to put this to test tomorrow.
 
Upvote 0
You must log in or register to reply here.

Similar threads

T
  • Question Question
How can I reduce file size of workbook referencing sheets in another workbook?
Replies
4
Views
209
bobsan42
bobsan42
N
  • Question Question
VBA to add title from formula to a save as name
Replies
0
Views
96
NKUNZI
N
W
  • Question Question
Formatting raw data with extra rows automatically added in-between records
Replies
1
Views
55
Peter_SSs
Peter_SSs
Z
  • Question Question
Print-to-PDF is corrupted in WIN11
Replies
1
Views
349
zombiemaster
Z
T
  • Question Question
Printing to PDF use VBA - Was working but now different sheets are different widths
Replies
1
Views
205
Tanquen
T

Forum statistics

Threads
1,223,894
Messages
6,175,254
Members
452,624
Latest member
gregg777

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