Oi!
Eu fiz uma leve gambiarra, mas acredito que traz o resultado desejado.
Como, pela configuração da impressão, não é possível ajeita para que imprima duas colunas, a minha ideia foi criar uma aba auxiliar em que a lista de compras seja copiada e impressa tal como desejado.
Segue o código:
Sub ImprimeLista()
'Imprime Lista do Mercado
Dim BlocPrint As Range
Dim FirstRow As Integer
Dim LastRow As Integer
Dim LastCol As Integer
Dim W As Worksheet
Dim WB As Worksheet
Application.DisplayAlerts = False
Sheets("Compras").Select
Cells(1, 1).Select
LastCol = ActiveSheet.Cells(4, 1).End(xlToRight).Column
FirstRow = Selection.Row
LastRow = Cells(Rows.Count, LastCol).End(xlUp).Row
'Adiciona uma nova aba e copia a tabela para ela
Sheets.Add After:=Sheets(Sheets.Count)
ActiveSheet.Name = "Impressão"
Set WB = Sheets("Impressão")
Set W = Sheets("Compras")
W.Select
'Seleciona a primeira metade
Set BlocPrint = W.Range(Cells(FirstRow, 1), Cells((LastRow / 2), LastCol))
BlocPrint.Select
Selection.Copy
WB.Select
WB.Range("A1").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, SkipBlanks:=False
Application.CutCopyMode = False
'Seleciona a segunda metade
W.Select
Set BlocPrint = W.Range(Cells((LastRow / 2), 1), Cells((LastRow), LastCol))
BlocPrint.Select
Selection.Copy
WB.Select
WB.Range("G4").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, SkipBlanks:=False
Application.CutCopyMode = False
'Coloca um cabeçalho na segunda coluna
WB.Range("A1:E3").Select
Selection.Copy
WB.Range("G1").Select
ActiveSheet.Paste
Application.CutCopyMode = False
Range("A1:E1").Select
'Ajeita as colunas com produtos
WB.Range("A:A").EntireColumn.AutoFit
WB.Range("G:G").EntireColumn.AutoFit
WB.Columns(6).ColumnWidth = 2
'Configura a impressão
With ActiveSheet.PageSetup
WB.Select
WB.Range("A:G").Select
' .Zoom = False
.FitToPagesWide = 1
.FitToPagesTall = False
Selection.PrintOut Copies:=1, Collate:=True
Range("A1").Select
End With
'Seleciona a planilha Compras e exclui a planilha Impressão
W.Select
W.Range("A1").Select
WB.Delete
Application.DisplayAlerts = True
End Sub
O resultado final foi esse: https://www.sendspace.com/file/6psv97
Espero que resolva.