Saving Selection Ranges on difrant sheets as One PDF

[mokhtar]

Hi everyone,

I have an excel file with 4 sheet
sheet1.range "A1" = "PRINTING"
sheet1.range "A5" = "MOKHTAR"
sheet1.range "D5" = 2015

sheet4.range "A1" = "PRINTING"

I'm trying to create a code to do this :

1- Select Worksheet.RANGE A1:F20 If Worksheet.Range("A1") = "PRINTING"
2- SAVE SELECTION RANGES AS ONE PDF FILE
PDF Name:="D:\" & Worksheets(1).Range("A5").Value & " " & Worksheets(1).Range(" D5 ").Value

Regards

[Kenneth Hobs]

In this case, there would be 2 PDF pages?

For your PDF name, you will need to concatenate ".pdf".

[mokhtar]

Thank you so much mr kenneth for the response
but there is a solution to create one pdf from selection ranges
I'll try this solution : copy selection ranges - add new sheet - paste - create one pdf from new sheet -delete new sheet
Could you help me to do this task please any suggestions are welcome
Thanks in advance for your help!!

[mokhtar]

HI mr kenneth
this is my solution to create one pdf from selection ranges on different sheets

Sub SaveAsPDFB2CON()

  Application.DisplayAlerts = False
  Application.ScreenUpdating = False
  
  Dim fName As String
  Dim i As Integer
  Dim ws As Worksheet
  fName = Worksheets(1).Range("A5").Value & " " & Worksheets(1).Range(" D5 ").Value
  
  Sheets.Add After:=Sheets(Sheets.Count)
  ActiveSheet.Name = "RESULT"
 
  For Each ws In ActiveWorkbook.Worksheets
 
  If ws.Name <> "RESULT" Then
  If ws.Range("A1") = "printing" Then ws.Activate
  ActiveSheet.Range("A1:f20").Copy Destination:=Sheets("RESULT").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
  End If

  Next ws
   
  Sheets("RESULT").Activate
  
  ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, FileName:="D:\" & fName, Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False
  
 
  Sheets("RESULT").Select
  ActiveWindow.SelectedSheets.Delete
  Sheets("1").Select
  
  Application.DisplayAlerts = True
  Application.ScreenUpdating = True
  
End Sub

but the data in sheet RESULT repeated 2 times
how i prevent this repeat
sorry for my bad english.
Regards

[Kenneth Hobs]

Your English is better than my anything other than English.

You are close. I would do this for you if needed but you seem to nearly have it anyway. I would use a few of the concepts that I used in the recent link below. You will notice that one seldom needs Select or Activate.

http://www.vbaexpress.com/forum/show...A-PDF-document

If you need me to add those concepts to yours, just let me know. You learn more by doing it yourself though. If you get it working, please post your final code.

[mokhtar]

mr kenneth you're really wonderful , Thanks for your time
the link is very useful , but I have tried several ways and get the same problem
Could you do this for me Just update my code to works exactly as i hoped
without any problem or repitition the data
Thanks in advance
mokhtar

[Kenneth Hobs]

I normally test code before posting but did not in this case. Try it out and if you can't see how to fix a problem, just post back. Always test code on a backup copy.

You will note that I used Debug.Print. This method can help you debug code when you view the output in the Immediate Window of the Visual Basic Editor (VBE).

Sub SaveAsPDFB2CON()  
  Dim fName As String, i As Integer, ws As Worksheet
  Dim cWS As Worksheet, rWS As Worksheet
  
  On Error GoTo EndSub
  Application.DisplayAlerts = False
  Application.ScreenUpdating = False
  
  Set cWS = ActiveSheet


  fName = "D:\" & Worksheets(1).Range("A5").Value2 & " " & Worksheets(1).Range("D5").Value2 & ".pdf"
  Debug.Print fName, Len(Dir(fName)) <> 0
   
  Set rWS = Worksheets.Add(After:=Sheets(Worksheets.Count))
  rWS.Name = "RESULT"
   
  For Each ws In Worksheets
    With ws
      If .Name <> "RESULT" Then
          If LCase(.Range("A1").Value2) = "printing" Then _
            .Range("A1:F20").Copy rWS.Range("A" & rWS.Rows.Count).End(xlUp).Offset(1)
      End If
    End With
  Next ws
   
  rWS.ExportAsFixedFormat Type:=xlTypePDF, Filename:=fName, _
    Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False
   
  rWS.Delete
  cWS.Activate
   
EndSub:
  Application.DisplayAlerts = True
  Application.ScreenUpdating = True
End Sub

[mokhtar]

Oh yeah

mr kenneth you're really fantastic
Thank you so much ... it works exactly as i hoped
Million Thanks