Set then print area based on a search

[Guest]

I would like to write a VBA macro that reads a predetermined list of
companies then searches rows in a spreadsheet then, when a match is found,
whether one row or multiples rows, defines the print area then finally prints
it. The rows in the spreadsheet are already grouped by company name. Any
suggestions?

 

[Guest]

Making assumptions for the myriad of details left out:

Sub PrintCompanies()
Dim rng as Range, rng1 as Range
Dim cell as Range, rTop as Range
Dim rBottom as Range

with worksheets("List")
set rng = .range(.cells(1,1),.cells(1,1).End(xldown))
End with

with worksheets("Data")
set rng1 = .Range(.Cells(2,1),.Cells(rows.count,1).End(xlup))


for each cell in rng
set rTop = rng1.Find(What:=cell, _
After:=rng1(rng1.count), _
LookIn:=xlFormulas, _
LookAt:=xlWhole, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False)

set rBottom = rng1.Find(What:=cell, _
After:=rng1(1), _
LookIn:=xlFormulas, _
LookAt:=xlWhole, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False)

if not rTop is nothing then
.range(rtop,rBottom).Resize(1,10).printout
End if
Next
End With
End sub

 

[Guest]

I apologize for not initially giving more details. I tested your code and it
essentially does what I need. Here are more details that will assist you in
providing me more specific resolution.

The "Data" spreadsheet contains 6 columns which must included in the
printout (Although it would be nice for the code to determine how many there
are.) The amount of rows for a company can vary from 1 to multiple rows. For
example, company1 may have 1 row, company2 may have 3 rows, etc. Most of the
time there is only one 8.5" x 11.0" printout per company.

 

[Guest]

By the way, the "Data" worksheet has one row containing column titles.

 

[Guest]

Sub PrintCompanies()
Dim rng as Range, rng1 as Range
Dim cell as Range, rTop as Range
Dim rBottom as Range

with worksheets("List")
set rng = .range(.cells(1,1),.cells(1,1).End(xldown))
End with

with worksheets("Data")
set rng1 = .Range(.Cells(2,1),.Cells(rows.count,1).End(xlup))


for each cell in rng
set rTop = rng1.Find(What:=cell, _
After:=rng1(rng1.count), _
LookIn:=xlFormulas, _
LookAt:=xlWhole, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False)

set rBottom = rng1.Find(What:=cell, _
After:=rng1(1), _
LookIn:=xlFormulas, _
LookAt:=xlWhole, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False)

if not rTop is nothing then
' changed 10 columns to 6 columns, also the 1 was a typo
.range(rtop,rBottom).Resize(,6).printout
End if
Next
End With
End sub

if you want to determine the number of columns

public Function NumColumns(rng as Range)
max = 1
for each cell in rng
col = rng.parent.cells(cell.row,"IV").End(xltoLeft).Column
if col > max then max = col
Next
NumColumns = col
End Function


then in the code

if not rTop is nothing then
' changed 10 columns to 6 columns:
set rng = .range(rtop,rBottom)
rng.Resize(,NumColumns(rng)).Printout
End if

 

[Guest]

I tested your revised code and it works very well. Would you assist me with
another enhancement? I'd like for the code to be able to print more than one
copy, let's say 2, for predetermined companies, not all of them, using, if
possible, the list of companies in the "List" worksheet.

 

[Tom Ogilvy]

assume the number of copies are to the right of the company name in the list
sheet (in column B)

Sub PrintCompanies()
Dim rng as Range, rng1 as Range
Dim cell as Range, rTop as Range
Dim rBottom as Range

with worksheets("List")
set rng = .range(.cells(1,1),.cells(1,1).End(xldown))
End with

with worksheets("Data")
set rng1 = .Range(.Cells(2,1),.Cells(rows.count,1).End(xlup))


for each cell in rng
set rTop = rng1.Find(What:=cell, _
After:=rng1(rng1.count), _
LookIn:=xlFormulas, _
LookAt:=xlWhole, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False)

set rBottom = rng1.Find(What:=cell, _
After:=rng1(1), _
LookIn:=xlFormulas, _
LookAt:=xlWhole, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False)

if not rTop is nothing then
' changed 10 columns to 6 columns, also the 1 was a typo
.range(rtop,rBottom).Resize(,6).printout copies:=cell.offset(0,1)
End if
Next
End With
End sub

 

[Tom Ogilvy]

that why

with worksheets("Data")
set rng1 = .Range(.Cells(2,1),.Cells(rows.count,1).End(xlup))



starts in row 2.

 

[Guest]

As expected, your code works great. Would it be possible to change either the
background color of the cells or the text color of the cells that were
printed?

 

[Guest]

Where do I place your code below?

public Function NumColumns(rng as Range)
max = 1
for each cell in rng
col = rng.parent.cells(cell.row,"IV").End(xltoLeft).Column
if col > max then max = col
Next
NumColumns = col
End Function

 

[Tom Ogilvy]

Sub PrintCompanies()
Dim rng as Range, rng1 as Range
Dim cell as Range, rTop as Range
Dim rBottom as Range

with worksheets("List")
set rng = .range(.cells(1,1),.cells(1,1).End(xldown))
End with

with worksheets("Data")
.Range("A:F").Interior.ColorIndex = xlNone
set rng1 = .Range(.Cells(2,1),.Cells(rows.count,1).End(xlup))


for each cell in rng
set rTop = rng1.Find(What:=cell, _
After:=rng1(rng1.count), _
LookIn:=xlFormulas, _
LookAt:=xlWhole, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False)

set rBottom = rng1.Find(What:=cell, _
After:=rng1(1), _
LookIn:=xlFormulas, _
LookAt:=xlWhole, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False)

if not rTop is nothing then
' changed 10 columns to 6 columns, also the 1 was a typo
With .range(rtop,rBottom).Resize(,6)
.printout copies:=cell.offset(0,1)
.Interior.ColorIndex = 3
End With
End if
Next
End With
End sub

 

[Tom Ogilvy]

In the same module as the other code.

 

[Guest]

Where specifically?

In the same module as the other code.

 

[Tom Ogilvy]

That was as specific as it needs to be. If you meet that condition, it is
in the right place.

 

[Guest]

It's all good. Until the next challenge...

That was as specific as it needs to be. If you meet that condition, it is
in the right place.