VBA Code to change orientation to Landscape help

D

Daniellel

Board Regular
Joined
Jun 21, 2011
Messages
242
Hi, i have an excel doc that currently has some code to copy a selection and paste it into a word document... I set it all up on a windows machine but now need to use it on a apple mac and what a surprise, it doesn't work! after hours of googling and amending my code to work with apple i am almost there... the only thing i cant seem to find online is how to make the word document Landscape... this is the code i have for windows and what i have for mac... it doesn't like the orientation of the margin sizes. Can anyone help?
Windows Code:
VBA Code: 
Dim objPrintWord, objPrintDoc As Object
    Set objPrintWord = CreateObject("Word.Application")
    Set objPrintDoc = objPrintWord.Documents.Add
        With objPrintDoc.PageSetup
        .Orientation = wdOrientLandscape
        .TopMargin = CentimetersToPoints(1)
        .BottomMargin = CentimetersToPoints(1)
        .LeftMargin = CentimetersToPoints(1)
        .RightMargin = CentimetersToPoints(1)
End With

Mac Code:
VBA Code: 
Dim oWord As Object
Application.Wait (3)
Set oWord = CreateObject(Class:=("Word.application"))
oWord.Visible = True
oWord.Activate
Dim oDoc
Set oDoc = oWord.Documents.Add

With oDoc.PageSetup
    .Orientation = wdOrientLandscape
    .TopMargin = CentimetersToPoints(1)
    .BottomMargin = CentimetersToPoints(1)
    .LeftMargin = CentimetersToPoints(1)
    .RightMargin = CentimetersToPoints(1)
End With
 
Sort by date Sort by votes
Can you not post from the Mac? Ideally, I'd like the full code for testing.
 
Upvote 0

Excel Facts

Easy bullets in Excel
If you have a numeric keypad, press Alt+7 on numeric keypad to type a bullet in Excel.
VBA Code: 
Sub MakeMBills()

'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''Pop Up Box
Dim MyString As String
Dim Response As String
Response = MsgBox("MAKE MALE BILLS?", 4, "PLEASE SELECT")
 ' User chose No.
If Response = vbNo Then    ' User chose Yes.
MyString = "No"    ' Perform some action.
End
Else
MyString = "Yes"    ' Perform some action.
End If
Application.ScreenUpdating = False

'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''Unhide Sheets
Sheet1.Visible = True
Sheet7.Visible = True
Sheet11.Visible = True
Sheet20.Visible = True
        
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''Update Sheet
'Sheet9.Select
'ActiveSheet.Shapes.Range(Array("PayM")).Select
'Selection.Delete
'Sheet20.Select
'On Error Resume Next
'ActiveSheet.Shapes.Range(Array("PayMB")).Select
'Application.CutCopyMode = False
'Selection.Cut
'Sheet9.Select
'Range("E5").Select
'ActiveSheet.Paste
'Range("D4").Select
'ActiveCell.FormulaR1C1 = "New Bills"


'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''Create All Word Docs
      
        ''''Bills Word
   Application.ScreenUpdating = True

Dim oWord As Object
Application.Wait (10)
DoEvents
Set oWord = CreateObject(Class:=("Word.application"))
oWord.Visible = True
oWord.Activate
Dim oDoc
Set oDoc = oWord.Documents.Add
Const wdOrientLandscape As Long = 1

'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''Start Tasks

'SetUp
Dim r As Long
Dim maxr As Long
Dim d As Long
maxr = Sheet1.Range("a" & Rows.Count).End(xlUp).Row
d = Sheet11.Range("a" & Rows.Count).End(xlUp).Row + 1
For r = 3 To maxr

'Action
Sheet1.Select
If Cells(r, 6) = "Male" Then
Sheet7.Select
Sheet7.Range("D10").Value = Sheet1.Cells(r, 3)
Sheet11.Select
Sheet11.Cells(d, 1).Value = Sheet7.Range("D10")
Sheet11.Cells(d, 2).Value = Sheet7.Range("I29")
Sheet11.Cells(d, 3).Value = Sheet7.Range("I30")
Sheet11.Cells(d, 4).Value = Sheet7.Range("I31")
Sheet11.Cells(d, 5).Value = Sheet7.Range("I32")
On Error Resume Next
   
'Copy To Word
Sheet7.Select
Range("Print_Area3").CopyPicture Appearance:=xlScreen, Format:=xlPicture
On Error Resume Next
oWord.Aapplication
oWord.Application.Selection.Paste.Special Link:=False, DataType:=15, _
        DisplayAsIcon:=False
oWord.Selection.TypeParagraph
d = d + 1
End If

'Next Task
Next r


'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''End Of All
Sheet1.Visible = False
Sheet7.Visible = False
Sheet11.Visible = False
Sheet20.Visible = False
Range("A1").Select
Application.ScreenUpdating = True
  
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''End Message
MsgBox ("Male Bills are now complete")

End Sub
 
Upvote 0
Where's the Pagesetup code gone?
 
Upvote 0
Well, it definitely won't work without it. :) Try this:

Code: 
Sub MakeMBills()

'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''Pop Up Box
Dim MyString As String
Dim Response As String
Response = MsgBox("MAKE MALE BILLS?", 4, "PLEASE SELECT")
 ' User chose No.
If Response = vbNo Then    ' User chose Yes.
MyString = "No"    ' Perform some action.
End
Else
MyString = "Yes"    ' Perform some action.
End If
Application.ScreenUpdating = False

'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''Unhide Sheets
Sheet1.Visible = True
Sheet7.Visible = True
Sheet11.Visible = True
Sheet20.Visible = True
        
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''Update Sheet
'Sheet9.Select
'ActiveSheet.Shapes.Range(Array("PayM")).Select
'Selection.Delete
'Sheet20.Select
'On Error Resume Next
'ActiveSheet.Shapes.Range(Array("PayMB")).Select
'Application.CutCopyMode = False
'Selection.Cut
'Sheet9.Select
'Range("E5").Select
'ActiveSheet.Paste
'Range("D4").Select
'ActiveCell.FormulaR1C1 = "New Bills"


'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''Create All Word Docs
      
        ''''Bills Word
   Application.ScreenUpdating = True

Dim oWord As Object
Const wdOrientLandscape As Long = 1
Const MARGIN_SIZE as double = 28.3465
Set oWord = CreateObject(Class:=("Word.application"))
Application.Wait (10)
DoEvents
oWord.Visible = True
oWord.Activate
Dim oDoc
Set oDoc = oWord.Documents.Add

       With oDoc.PageSetup
        .Orientation = wdOrientLandscape
        .TopMargin = MARGIN_SIZE 
        .BottomMargin = MARGIN_SIZE 
        .LeftMargin = MARGIN_SIZE 
        .RightMargin = MARGIN_SIZE 
    end with
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''Start Tasks

'SetUp
Dim r As Long
Dim maxr As Long
Dim d As Long
maxr = Sheet1.Range("a" & Rows.Count).End(xlUp).Row
d = Sheet11.Range("a" & Rows.Count).End(xlUp).Row + 1
For r = 3 To maxr

'Action
Sheet1.Select
If Cells(r, 6) = "Male" Then
Sheet7.Select
Sheet7.Range("D10").Value = Sheet1.Cells(r, 3)
Sheet11.Select
Sheet11.Cells(d, 1).Value = Sheet7.Range("D10")
Sheet11.Cells(d, 2).Value = Sheet7.Range("I29")
Sheet11.Cells(d, 3).Value = Sheet7.Range("I30")
Sheet11.Cells(d, 4).Value = Sheet7.Range("I31")
Sheet11.Cells(d, 5).Value = Sheet7.Range("I32")
On Error Resume Next
   
'Copy To Word
Sheet7.Select
Range("Print_Area3").CopyPicture Appearance:=xlScreen, Format:=xlPicture
On Error Resume Next
oWord.Application
oWord.Application.Selection.Paste.Special Link:=False, DataType:=15, _
        DisplayAsIcon:=False
oWord.Selection.TypeParagraph
d = d + 1
End If

'Next Task
Next r


'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''End Of All
Sheet1.Visible = False
Sheet7.Visible = False
Sheet11.Visible = False
Sheet20.Visible = False
Range("A1").Select
Application.ScreenUpdating = True
  
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''End Message
MsgBox ("Male Bills are now complete")

End Sub
 
Upvote 0
RoryA said:
Well, it definitely won't work without it. :) Try this:

Code: 
Sub MakeMBills()

'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''Pop Up Box
Dim MyString As String
Dim Response As String
Response = MsgBox("MAKE MALE BILLS?", 4, "PLEASE SELECT")
' User chose No.
If Response = vbNo Then    ' User chose Yes.
MyString = "No"    ' Perform some action.
End
Else
MyString = "Yes"    ' Perform some action.
End If
Application.ScreenUpdating = False

'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''Unhide Sheets
Sheet1.Visible = True
Sheet7.Visible = True
Sheet11.Visible = True
Sheet20.Visible = True
       
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''Update Sheet
'Sheet9.Select
'ActiveSheet.Shapes.Range(Array("PayM")).Select
'Selection.Delete
'Sheet20.Select
'On Error Resume Next
'ActiveSheet.Shapes.Range(Array("PayMB")).Select
'Application.CutCopyMode = False
'Selection.Cut
'Sheet9.Select
'Range("E5").Select
'ActiveSheet.Paste
'Range("D4").Select
'ActiveCell.FormulaR1C1 = "New Bills"


'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''Create All Word Docs
     
        ''''Bills Word
   Application.ScreenUpdating = True

Dim oWord As Object
Const wdOrientLandscape As Long = 1
Const MARGIN_SIZE as double = 28.3465
Set oWord = CreateObject(Class:=("Word.application"))
Application.Wait (10)
DoEvents
oWord.Visible = True
oWord.Activate
Dim oDoc
Set oDoc = oWord.Documents.Add

       With oDoc.PageSetup
        .Orientation = wdOrientLandscape
        .TopMargin = MARGIN_SIZE
        .BottomMargin = MARGIN_SIZE
        .LeftMargin = MARGIN_SIZE
        .RightMargin = MARGIN_SIZE
    end with
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''Start Tasks

'SetUp
Dim r As Long
Dim maxr As Long
Dim d As Long
maxr = Sheet1.Range("a" & Rows.Count).End(xlUp).Row
d = Sheet11.Range("a" & Rows.Count).End(xlUp).Row + 1
For r = 3 To maxr

'Action
Sheet1.Select
If Cells(r, 6) = "Male" Then
Sheet7.Select
Sheet7.Range("D10").Value = Sheet1.Cells(r, 3)
Sheet11.Select
Sheet11.Cells(d, 1).Value = Sheet7.Range("D10")
Sheet11.Cells(d, 2).Value = Sheet7.Range("I29")
Sheet11.Cells(d, 3).Value = Sheet7.Range("I30")
Sheet11.Cells(d, 4).Value = Sheet7.Range("I31")
Sheet11.Cells(d, 5).Value = Sheet7.Range("I32")
On Error Resume Next
  
'Copy To Word
Sheet7.Select
Range("Print_Area3").CopyPicture Appearance:=xlScreen, Format:=xlPicture
On Error Resume Next
oWord.Application
oWord.Application.Selection.Paste.Special Link:=False, DataType:=15, _
        DisplayAsIcon:=False
oWord.Selection.TypeParagraph
d = d + 1
End If

'Next Task
Next r


'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''End Of All
Sheet1.Visible = False
Sheet7.Visible = False
Sheet11.Visible = False
Sheet20.Visible = False
Range("A1").Select
Application.ScreenUpdating = True
 
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''End Message
MsgBox ("Male Bills are now complete")

End Sub
Click to expand...
That is amazing! thank you so much!
I am still new to VBA and have been searching google and trying myself to fix it for nearly 3 days!!! Thank you!
 
Upvote 0
Glad to help. :)

If you are new to VBA, you've definitely jumped in at the deep end with trying to create code that works on Macs and PCs. That is not for the faint-hearted!!
 
Upvote 0
RoryA said:
Well, if you haven't already, you may want to bookmark Ron's Mac tips page here: Excel for the Mac Tips
Click to expand...
Rory, this code has been working fine but i am having an issue where sometimes my mac does not open a new doc in word when it is supposed to and then none of my updates happen - is there a way of getting the code to check if it has opened correctly and if not try to reopen it?
 
Upvote 0
You must log in or register to reply here.

Similar threads

L
  • Question
MailMerge Can't Find My File
Replies
2
Views
288
Joe4
Joe4
J
  • Question
Error 462 - "The remote server machine does not exist" when working with Word via Excel VBA
Replies
9
Views
4K
Macropod
Macropod
B
  • Question
export to word issue
Replies
1
Views
398
BrendanDixon
B
G
  • Solved
Still no solution after 1 Year - Please Help
2
Replies
10
Views
365
jolivanes
jolivanes
M
  • Solved
VBA to Convert and Merge .PNG to .PDF
Replies
2
Views
2K
michele227
M

Forum statistics

Threads
1,214,918
Messages
6,122,257
Members
449,075
Latest member
staticfluids

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