I have code for automatically inserting Page Breaks depending on sections in Column C.
My sections are in 4 rows.
Here is the code that used to work sometimes when sections were in Column B, now sections are in Column C and I have changed range but it does not seem to work:
Dim fnd As Range, r As Range, pb As Variant
Dim PrintVersion As Worksheet
Set PrintVersion = ThisWorkbook.Sheets("Print version")
PrintVersion.Activate
' make sure sheet is in page break view
PrintVersion.Parent.Windows(1).View = xlPageBreakPreview
' first clear any set page breaks
On Error Resume Next
For Each pb In PrintVersion.HPageBreaks
pb.Delete
Next
On Error GoTo 0
' move preposed breaks to top of segement
With PrintVersion.HPageBreaks
For pb = 1 To .Count
Set r = Cells(.Item(pb).Location.Row, 3)
Set fnd = Range("C:C").Find("*", r, , , , xlPrevious)
If Not Intersect(fnd.Offset(, -1).Resize(fnd.Offset(, 1).End(xlDown).Row - fnd.Row + 1, 4), r) Is Nothing Then
Set .Item(pb).Location = fnd
DoEvents
End If
Next
End With
Before that I have Wrapping and autofitting:
With PrintVersion.Range("Print_Area")
With .Cells.Rows
.WrapText = True
.VerticalAlignment = xlCenter
.EntireRow.AutoFit
End With
End With
Result (page break should be on row 148):
I suggest to reset all pagebreaks by ResetAllPageBreaks and to Find in the first column:
Private Sub BreakPages()
Dim fnd As Range, r As Range, pb As Variant
Dim PrintVersion As Worksheet
Set PrintVersion = ThisWorkbook.Sheets("Print version")
PrintVersion.Activate
' make sure sheet is in page break view
PrintVersion.Parent.Windows(1).View = xlPageBreakPreview
' first clear any set page breaks
PrintVersion.ResetAllPageBreaks
' move preposed breaks to top of segement
With PrintVersion.HPageBreaks
For pb = 1 To .Count
' check if first column is empty
Set r = PrintVersion.Cells(.Item(pb).Location.Row, 1)
If r.value = "" Then
' find previous cell in column 1 which is not empty
Set fnd = PrintVersion.Columns(1).Find("*", r, , , , xlPrevious)
' set page break 1 row above it
Set .Item(pb).Location = fnd.Offset(-1, 0)
DoEvents
End If
Next
End With
End Sub
Related
For i = 1 + num_ranges To n
ws.Range("newRange").Copy
Set nextCell = ws.Cells(ws.Rows.Count, "A").End(xlUp).Offset(2, 0)
nextCell.PasteSpecial xlPasteAll
Next i
Currently copy and pasting a range up to N times and it works just fine. What I would like is to only paste it if the entire range can fit in the page. Otherwise, go to the next page and continue pasting.
The way I'm thinking is to only paste if (Last row in page - nextCell) > the amount of rows the range has (6) else set nextCell to first row in next page but can't figure out how to get the last (or first row) of current/next page.
Here's some code I used for testing. You should be able to adjust for your needs.
Sub CopyPasteWithPageBreaks()
Dim f As Worksheet, i As Long, rngCopy As Range, rngPaste As Range
Dim pb As Long, newPaste As Range, pgBrk As HPageBreak, nC, nR
Set rngCopy = Sheets("Sheet2").Range("A1:I20") 'some data to copy
nC = rngCopy.Columns.Count
nR = rngCopy.Rows.Count
Set f = Sheets("Sheet1")
f.Cells.Clear
DoEvents
Set rngPaste = f.Range("A1")
For i = 1 To 10
pb = f.HPageBreaks.Count 'current # of page breaks
'set up the copy range so it's clear which iteration the pasted content was from
rngCopy.Value = i
rngCopy.Font.Color = IIf(i Mod 2 = 0, vbRed, vbBlue)
rngCopy.Copy rngPaste
DoEvents
If f.HPageBreaks.Count > pb Then 'added a page break by pasting?
If i = 1 Then
'If the first paste creates a new page break then
' the copied range will not fit on a page....
MsgBox "Range is too large for 1 page!"
Exit Sub
End If
Set pgBrk = f.HPageBreaks(f.HPageBreaks.Count)
Debug.Print "new pagebreak " & pgBrk.Location.Address
Set newPaste = f.Cells(pgBrk.Location.Row, "A")
rngPaste.Resize(nC, nR).Clear 'clear last paste
rngCopy.Copy newPaste 're-copy to top of next page
Set rngPaste = newPaste.Offset(nR)
Else
Set rngPaste = rngPaste.Offset(nR)
End If
Next i
End Sub
I was asking for help with the code in the following question:
Insert value based on drop down list from cell next to matched one
With a big effort of #Variatus who helped me to find the solution I have working code to "insert value based on drop down list from cell next to matched one" which works in both ways. When I was playing around to to get deep in the code I tried to figure out how to use Worksheet_Change for formula calculation. I wanted to avoid complex code so I'm checking column "D" with dropdown list values and when this is changed then calculated formula value in the column "E" is copied to matched cell in the next table. Everything works like a charm on my "Sheet1". But when I tried to replicate the code to my "Sheet2" it stopped working this way even I didn't change anything. Maybe I'm missing something but I can't figure out what it is. I tried start over from the beginning but still nothing.
And here are two PrtScns of "Sheet1" and "Sheet2":
Sheet1
Sheet2
And this the code I used for Sheet1 which works with no issue:
Option Explicit
Enum Nws ' worksheet where 'Data' values are used
' 060-2
NwsFirstDataRow = 10 ' change to suit
NwsTrigger = 8 ' Trigger column (5 = column E)
NwsTarget = 10 ' Target column (no value = previous + 1)
End Enum
Enum Nta ' columns of range 'Data'
' 060
NtaId = 1 ' 1st column of 'Data' range
NtaVal = 4 ' 3rd column of 'Data' range
End Enum
Private Sub Worksheet_Change(ByVal Target As Range)
' 060-2
Dim Rng As Range
Dim Tmp As Variant
' skip action if more than 1 cell was changed
If Target.CountLarge > 1 Then Exit Sub
Set Rng = Range(Cells(NwsFirstDataRow, NwsTrigger), _
Cells(Rows.Count, NwsTrigger).End(xlUp))
If Not Application.Intersect(Target, Rng) Is Nothing Then
With Application
Tmp = .VLookup(Target.Value, Range("Data"), NtaVal, False)
If Not IsError(Tmp) Then
.EnableEvents = False ' suppress 'Change' event
Cells(Target.Row, NwsTarget).Value = Tmp
.EnableEvents = True
End If
End With
Else
Set Rng = Range("B2:E4") ' change to suit
If Not Application.Intersect(Target, Rng.Columns(NtaVal - 1)) Is Nothing Then
' If Not Application.Intersect(Target, Range("D2:D4")) Is Nothing Then
UpdateCategory Cells(Target.Row, Rng.Column).Resize(1, NtaVal).Value
End If
End If
End Sub
Private Sub Worksheet_activate()
' 060-2
Dim TgtWs As Worksheet ' the Tab on which 'Data' was used
Dim Cat As Variant ' 'Data' category (2 cells as Nta)
Dim R As Long ' loop counter: rows
Set TgtWs = Sheet1 ' change to match your facts
With Range("Data") ' change to match your facts
For R = 1 To .Rows.Count
Cat = .Rows(R).Value
UpdateCategory Cat
Next R
End With
End Sub
Private Sub UpdateCategory(Cat As Variant)
' 060-2
Dim Fnd As Range ' matching cell
Dim FirstFound As Long ' row of first match
Dim Rng As Range
Application.EnableEvents = False
Set Rng = Range(Cells(NwsFirstDataRow, NwsTrigger), _
Cells(Rows.Count, NwsTrigger).End(xlUp))
With Rng
Set Fnd = .Find(Cat(1, NtaId), LookIn:=xlValues, LookAt:=xlWhole)
If Not Fnd Is Nothing Then
FirstFound = Fnd.Row
Do
Cells(Fnd.Row, NwsTarget).Value = Cat(1, NtaVal)
Set Fnd = .FindNext(Fnd)
If Fnd Is Nothing Then Exit Do
Loop While Fnd.Row <> FirstFound
End If
End With
Application.EnableEvents = True
End Sub
And the code for Sheet2 which doesn't:
Option Explicit
Enum Nws1 ' worksheet where 'Data1' values are used
' 060-2
Nws1FirstData1Row = 16 ' change to suit
Nws1Trigger = 18 ' Trigger column (5 = column E)
Nws1Target = 20 ' Target column (no value = previous + 1)
End Enum
Enum Nta1 ' columns of range 'Data1'
' 060
Nta1Id = 1 ' 1st column of 'Data1' range
Nta1Val = 5 ' 3rd column of 'Data1' range
End Enum
Private Sub Worksheet_Change(ByVal Target As Range)
' 060-2
Dim Rng As Range
Dim Tmp As Variant
' skip action if more than 1 cell was changed
If Target.CountLarge > 1 Then Exit Sub
Set Rng = Range(Cells(Nws1FirstData1Row, Nws1Trigger), _
Cells(Rows.Count, Nws1Trigger).End(xlUp))
If Not Application.Intersect(Target, Rng) Is Nothing Then
With Application
Tmp = .VLookup(Target.Value, Range("Data1"), Nta1Val, False)
If Not IsError(Tmp) Then
.EnableEvents = False ' suppress 'Change' event
Cells(Target.Row, Nws1Target).Value = Tmp
.EnableEvents = True
End If
End With
Else
Set Rng = Range("M19:M25") ' change to suit
If Not Application.Intersect(Target, Rng.Columns(Nta1Val - 2)) Is Nothing Then
UpdateCategory Cells(Target.Row, Rng.Column).Resize(1, Nta1Val).Value
End If
End If
End Sub
Private Sub Worksheet_activate()
' 060-2
Dim TgtWs As Worksheet ' the Tab on which 'Data1' was used
Dim Cat As Variant ' 'Data1' category (2 cells as Nta1)
Dim R As Long ' loop counter: rows
Set TgtWs = Sheet2 ' change to match your facts
With Range("Data1") ' change to match your facts
For R = 1 To .Rows.Count
Cat = .Rows(R).Value
UpdateCategory Cat
Next R
End With
End Sub
Private Sub UpdateCategory(Cat As Variant)
' 060-2
Dim Fnd As Range ' matching cell
Dim FirstFound As Long ' row of first match
Dim Rng As Range
Application.EnableEvents = False
Set Rng = Range(Cells(Nws1FirstData1Row, Nws1Trigger), _
Cells(Rows.Count, Nws1Trigger).End(xlUp))
With Rng
Set Fnd = .Find(Cat(1, Nta1Id), LookIn:=xlValues, LookAt:=xlWhole)
If Not Fnd Is Nothing Then
FirstFound = Fnd.Row
Do
Cells(Fnd.Row, Nws1Target).Value = Cat(1, Nta1Val)
Set Fnd = .FindNext(Fnd)
If Fnd Is Nothing Then Exit Do
Loop While Fnd.Row <> FirstFound
End If
End With
Application.EnableEvents = True
End Sub
Any help would be well appreciated!
This is an excerpt from the original code.
Set Rng = Range("Data") ' change to suit
If Not Application.Intersect(Target, Rng.Columns(NtaVal)) Is Nothing Then
UpdateCategory Cells(Target.Row, Rng.Column).Resize(1, NtaVal).Value
End If
Below is the corresponding part from your code behind Sheet1.
Set Rng = Range("B2:E4") ' change to suit
If Not Application.Intersect(Target, Rng.Columns(NtaVal - 1)) Is Nothing Then
UpdateCategory Cells(Target.Row, Rng.Column).Resize(1, NtaVal).Value
End If
And here is the exact same part from your code behind Sheet2.
Set Rng = Range("M19:M25") ' change to suit
If Not Application.Intersect(Target, Rng.Columns(Nta1Val - 2)) Is Nothing Then
UpdateCategory Cells(Target.Row, Rng.Column).Resize(1, Nta1Val).Value
End If
Now you can analyse what happened.
The Data range was declared by name to relieve you of the chore to check the address multiple times. You need it on the sheet and you need it in the code. You set it once and it will be correct wherever you use the name.
In your own rendering of the same code you changed the name to a sheet address: Range("B2:E4"). It's true that it makes no difference, except that you have to check to be sure that Range("B2:E4") really is the same as Data. It's extra work but it works.
with Set Rng = Range("M19:M25") you walked into the trap which you set for yourself. By your design this is supposed to be the named range Data1. But it isn't. Data1 has 5 columns and the range you declare in its place has only 1.
From the above analysis it's very clear by which logic you arrived at the mistake. You didn't "own" the named range. Therefore you strove to replace it with coordinates. In the process you gave up the safety that comes from using named variables and then failed to put in the extra checking needed when you take extra risk.
Please observe the missing intent for the line UpdateCategory Cells(Target... in your code for Sheet2. The indent serves to show the beginning and End of the IF statement. One would expect a beginner to need more of such help reading code than an expert. Truth is however that all beginners (your good-self included) think it makes no difference, and it really doesn't, but more advanced programmers know that they need clarity above all else. You can tell the experience of a programmer from the indenting he applies in his code. It's a very reliable indicator.
Here is VBA I use to automatically insert page breaks while printing to pdf. Code seems to work if there is more than one page. However if there is only page in document debugger gives an error
Run-time error 9: Subscript out of range
pointing to Set r = PrintVersion.Cells(.Item(pb).Location.Row, 1). Any ideas what is the problem and how to repair it?
Here is my code:
Sub Print()
Dim Cell As Range
Dim tempFolderPath As String
Dim filePath As String
Dim fileTitle As String
Dim fnd As Range, r As Range, pb As Variant
Dim PrintVersion As Worksheet
Dim WData As Worksheet
Dim rw As Range, hideRange As Range
Set PrintVersion = ThisWorkbook.Sheets("Print version")
Set WData = ThisWorkbook.Sheets("Data")
With PrintVersion.Range("Print_Area")
With .Cells.Rows
.WrapText = True
.VerticalAlignment = xlCenter
.EntireRow.AutoFit
End With
' Hide blank rows with formulas giving as a result ""
For Each rw In .Rows
For Each Cell In rw.Cells
If Cell.HasFormula Then
If Cell.Value = "" Then
If Not rw.Hidden Then
If hideRange Is Nothing Then
Set hideRange = rw
Else
Set hideRange = Union(hideRange, rw)
End If
Exit For ' no need to process rest of the row
End If
End If
End If
Next
Next
If Not hideRange Is Nothing Then hideRange.EntireRow.Hidden = True
End With
' Set print area till the last cell
PrintVersion.PageSetup.PrintArea = PrintVersion.Range("A1:C" & _
PrintVersion.[LOOKUP(2,1/(C1:C250<>""),ROW(C1:C250))]).Address
' make sure sheet is in page break view
PrintVersion.Parent.Windows(1).View = xlPageBreakPreview
' first clear any set page breaks
PrintVersion.ResetAllPageBreaks
' move preposed breaks to top of segement
With PrintVersion.HPageBreaks
pb = 1
Do
' check if first column is empty
Set r = PrintVersion.Cells(.Item(pb).Location.Row, 1)
If r.Value = "" Then
' find previous cell in column 1 which is not empty
Set fnd = PrintVersion.Columns(1).Find("*", r, , , , xlPrevious)
' set page break 1 row above it
Set .Item(pb).Location = fnd.Offset(-1, 0)
DoEvents
End If
pb = pb + 1
If pb > .Count Then Exit Do
Loop
End With
' create a path for a temporary file
tempFolderPath = Environ("Temp")
fileTitle = "CV_" & Sheets("Filling form").Range("F7") & "_" & Sheets("Filling form").Range("F9")
filePath = tempFolderPath & "\" & fileTitle & ".pdf"
PrintVersion.ExportAsFixedFormat xlTypePDF, filePath, xlQualityStandard, True, , , , False
Set PrintVersion = Nothing
Set WData = Nothing
End Sub
So if there are no pagebreaks you do not need to handle them, right? Check if there are any before going into it:
With PrintVersion.HPageBreaks
If .Count > 0 Then
pb = 1
Do
' check if first column is empty
Set r = PrintVersion.Cells(.Item(pb).Location.Row, 1)
If r.Value = "" Then
' find previous cell in column 1 which is not empty
Set fnd = PrintVersion.Columns(1).Find("*", r, , , , xlPrevious)
' set page break 1 row above it
Set .Item(pb).Location = fnd.Offset(-1, 0)
DoEvents
End If
pb = pb + 1
If pb > .Count Then Exit Do
Loop
End If
End With
(not tested)
I have two spreadsheets, vda.xlsx and main.xlsm. At the moment I'm comparing the values in:
main.xlsm column J
with
vda.xlsx column A
To see if there is a match. If a match is found then the value in column gets highlighted in red.
However the format of the data in vda.xlsx column A has changed .
It used to look like this
1234
Now it looks like this
Test\1234 or Best\1234 or Jest\1234 - it could be anything...
Sp I need to split Test\1234 by the "\" and extract 1234 for comparison.
Any idea how I can accomplish this. This is my code so far:
Sub VDA_Update()
Dim wshT As Worksheet
Dim wbk As Workbook
Dim wshS As Worksheet
Dim r As Long
Dim m As Long
Dim cel As Range
Application.ScreenUpdating = False
Set wshT = ThisWorkbook.Worksheets("Master")
On Error Resume Next
' Check whether vda.xlsx is already open
Set wbk = Workbooks("vda.xlsx")
On Error GoTo 0
If wbk Is Nothing Then
' If not, open it
Set wbk = Workbooks.Open("C:\Working\vda_test.xlsx")
End If
' Set worksheet on vda.xlsx
Set wshS = wbk.Worksheets("imac01")
m = wshT.Cells(wshT.Rows.Count, 1).End(xlUp).Row
' Loop though cells in column J on main.xlsm
For r = 1 To m
' Can we find the value in column C of vda.xlsx?
Set cel = wshS.Columns(1).Find(What:=wshT.Cells(r, 10).Value, _
LookAt:=xlWhole, MatchCase:=False)
If Not cel Is Nothing Then
' If we find a match, then change the text to red
wshT.Cells(r, 10).Font.ColorIndex = 3
End If
Next r
Application.ScreenUpdating = True
End Sub
Use Split(CellValue, "\") to get an array and then retrieve the last item in the array.
Change:
' Loop though cells in column J on main.xlsm
For r = 1 To m
' Can we find the value in column C of vda.xlsx?
Set cel = wshS.Columns(1).Find(What:=wshT.Cells(r, 10).Value, _
LookAt:=xlWhole, MatchCase:=False)
If Not cel Is Nothing Then
' If we find a match, then change the text to red
wshT.Cells(r, 10).Font.ColorIndex = 3
End If
Next r
To something like:
' Loop though cells in column A on vda.xlsx
For r = 1 To m
' Can we find the value in column J of main.xlsm?
cellSplit = Split(wshS.Cells(r, 1).Value, "\")
Set cel = wshT.Columns(10).Find(cellSplit(UBound(cellSplit)), _
LookAt:=xlWhole, MatchCase:=False)
If Not cel Is Nothing Then
' If we find a match, then change the text to red
cel.Cells(1, 1).Font.ColorIndex = 3
End If
Next r
I'm programmatically inserting some text into merged cells in a row. I have Wrap Text set and want the row height to expand as necessary to accommodate multiple lines of text. I was programmatically applying AutoFit once the cells had been filled but that didn't work. I subsequently found a Knowledge Base article saying the AutoFit doesn't work for merged cells! I can try to compute the row height required to accommodate the number of lines of wrapping text. But I don't really want to climb into calculating character widths etc. Any ideas gratefully appreciated.
Question credit goes to David (I had the exact same question, just reposting here for posterity) source
I found a VB macro here that will simulate the autofit of any merged cells on the active sheet. Source credits parry from MrExcel.com
Sub AutoFitMergedCellRowHeight()
Dim CurrentRowHeight As Single, MergedCellRgWidth As Single
Dim CurrCell As Range
Dim ActiveCellWidth As Single, PossNewRowHeight As Single
Dim StartCell As Range, c As Range, MergeRng As Range, Cell As Range
Dim a() As String, isect As Range, i
'Take a note of current active cell
Set StartCell = ActiveCell
'Create an array of merged cell addresses that have wrapped text
For Each c In ActiveSheet.UsedRange
If c.MergeCells Then
With c.MergeArea
If .Rows.Count = 1 And .WrapText = True Then
If MergeRng Is Nothing Then
Set MergeRng = c.MergeArea
ReDim a(0)
a(0) = c.MergeArea.Address
Else
Set isect = Intersect(c, MergeRng)
If isect Is Nothing Then
Set MergeRng = Union(MergeRng, c.MergeArea)
ReDim Preserve a(UBound(a) + 1)
a(UBound(a)) = c.MergeArea.Address
End If
End If
End If
End With
End If
Next c
Application.ScreenUpdating = False
'Loop thru merged cells
For i = 0 To UBound(a)
Range(a(i)).Select
With ActiveCell.MergeArea
If .Rows.Count = 1 And .WrapText = True Then
'Application.ScreenUpdating = False
CurrentRowHeight = .RowHeight
ActiveCellWidth = ActiveCell.ColumnWidth
For Each CurrCell In Selection
MergedCellRgWidth = CurrCell.ColumnWidth + MergedCellRgWidth
Next
.MergeCells = False
.Cells(1).ColumnWidth = MergedCellRgWidth
.EntireRow.AutoFit
PossNewRowHeight = .RowHeight
.Cells(1).ColumnWidth = ActiveCellWidth
.MergeCells = True
.RowHeight = IIf(CurrentRowHeight > PossNewRowHeight, _
CurrentRowHeight, PossNewRowHeight)
End If
End With
MergedCellRgWidth = 0
Next i
StartCell.Select
Application.ScreenUpdating = True
'Clean up
Set CurrCell = Nothing
Set StartCell = Nothing
Set c = Nothing
Set MergeRng = Nothing
Set Cell = Nothing
End Sub