many sheets from "master data"

B

Btibert

Hi guys,

In the last few days, ive posted some questions with some success, bu
not being able to completely work though my problem. Given that I a
novice/intermediate in relation to VBA, I am having extreme difficult
augmenting the code to do what i like.

Attached is the file so you can visualize what I am talking about.

What I want to do is to put each "page" of data on a new slide. As yo
can see, all the data is found on the first page. In column T, you ca
see where each new page starts (as indicated by the data and pag
number).

I having trying tirelessly to get the code such that at each break
pages are created for the data, such that if my report contains 30
pages, each sheet in the workbook will be a page from the report.

My attempts have been to search for text, a succession of completel
blank rows (typically 3 blank rows between each page), etc.

I was hoping a visual look to my problem's description would help.

Thanks for any help you can provide,

Broc
 
B

Btibert

this is my last attempt.

I am attaching the rawdata compressed document, that is fixed column
no other format (if you open it, the format will be all over the place
but you should be able to see my problem at hand)

For the excel document, if you want that, drop me an email at
[email protected], I will gladly send it to you.

Thanks again,

broc

Attachment filename: data.xls
Download attachment: http://www.excelforum.com/attachment.php?postid=65530
 
G

Greg Wilson

I had a look at the "raw data compressed document" as per
your request. The following code is intended to demo the
difficulty accomplishing your goal based on looping
through column K checking for 3 blank cells in a row. Note
that the macro is more elaborate than necessary because it
has been enhanced for the purpose of the demo. It is not
intended that you study the code but instead just run the
demo on the "raw data compressed document".

For your goal to be feasible, there must be a consistent
and reliable means to identify both the end of a data
range as well as the beginning of the next data range
based on cell contents. At least on cursory examination,
this does not appear to be the case.

As currently designed, once three blank cells in a row
have been found in column K, the macro must then find
nonblank cells that coincide with the start of a new data
range. The macro is designed to reset once nonblank cells
are found. It ultimately fails because resumption of
nonblank cells does not occur in column K at (or before)
the start of new data range. If this requirement is
omitted (i.e. it resets automatically), then if blank
cells continue, once three more have been counted, a new
data range will be identified; which, in this case, this
would also be erroneous. (It is assumed that the page
numbering in column T is artificial and can't be used by
the macro for referencing).

Your comments on how to identify the beginning and end of
a data range based on cell contents is requested if indeed
this is possible.

Paste the following code to a standard module. WARNING:
This code will delete sheets in the workbook that have
names beggining with "Page ". This is by design in order
to allow you to run it more than once without having to
manually delete the added pages.

Start of code. Correct for wordwrap:

Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As
Long)
Sub BreakData2()
Dim wks0 As Worksheet
Dim wks As Worksheet, wks2 As Worksheet
Dim rng As Range, rng2 As Range
Dim c As Range, cc As Range
Dim x As Long, i As Long, ii As Long
Dim AddPage As Boolean

For Each wks0 In ThisWorkbook.Worksheets
If Left(wks0.Name, 5) = "Page " Then wks0.Delete
Next
ActiveSheet.Cells.Interior.ColorIndex = xlNone
Set wks0 = ActiveSheet
ActiveWindow.Zoom = 50
'On Error Resume Next
Set wks2 = Sheets(Sheets.Count)
x = Cells(Rows.Count, 11).End(xlUp).Row
Set rng = Application.Intersect(ActiveSheet.UsedRange, _
Range(Cells(3, 11), Cells(Rows.Count, 11)))
Set cc = rng(1)
i = 0: ii = 0: x = 0
For Each c In rng
ii = ii + 1
c.Select
c.EntireRow.Interior.ColorIndex = x + 4
Sleep 200
If Trim(c) = "" Then
i = i + 1
If i = 3 Then
Range(c, c(-1,
1)).EntireRow.Interior.ColorIndex = xlNone
Range(c, c(-1, 1)).Select
MsgBox "Three blank cells in a row found."
Selection.Interior.ColorIndex = 15
Set rng2 = Range(cc, rng(ii - 3)).EntireRow
Set cc = c(2)
AddPage = True
End If
ElseIf ii = rng.Count Then
Set rng2 = Range(cc, rng(ii)).EntireRow
AddPage = True
Else
i = 0
End If
If AddPage = True Then
rng2.Select
AddPage = False
'i = 0
x = x + 1
MsgBox "Adding new sheet for range " &
rng2.Address & vbCr & _
"New sheet Page No. " & x
Set wks = Sheets.Add(After:=wks2)
wks.Name = "Page " & x
Set wks2 = wks
With wks
Range(.Cells(1, 1), .Cells(rng2.Count,
1)).EntireRow. _
Value = rng2.Value
End With
wks0.Activate
End If
Next
'On Error GoTo 0
End Sub

Regards,
Greg
 
G

Greg Wilson

On further examination, if we use column L instead of K
and include the rider that there must be at least, say 10,
lines for each data range, then it worked for the data set
provided. It would have to been confirmed that the
complete data set is consistent.

Note that cells L8, L63, L98 and L153 appear to have data
but instead are blank resulting in 3 *premature* blank
cells in a row. The above rider compensates for this.

Regards,
Greg
 
B

Btibert

First let me state how extremely grateful I am that you are willing t
take the time to assist me in my problem.

The code works great! I made the changes such that it is based off o
row L, but am not able to find the line of code that requires at leas
ten rows of data to be in the range.

Also, I am not sure whether or not it is necessary that "user" watche
the code take place, as evidenced by each row being highlighted. Is i
a huge change to have the macro run quicker? If it is, please do no
change it, it is most certainly acceptable the way it is. Obvioulsy i
it is a requirement to have the code run "visually", then I will no
lose any sleep over this.

Again, thank you for all of your assistance. When I started attemptin
this code last week, I thought it was in my range of ability, bu
obviously if it were not for you, I would not be anywhere close.

Thanks again,

Broc
 
G

Greg Wilson

Hi Brock,

The fancy highlighting etc. was intended as a demo only
for your benefit. The actual intended code is much simpler
and faster (appended below). I thought the demo would be
useful to you so that you could see exactly what it's
doing. And therefore, if it fails when applied to ALL your
data, you could see why. You could thus stategize the
solution. I had assumed that the rest of the data wasn't
necessarily structured exactly the same. My earlier
attempts were based on a much simpler mental picture of
the data and therefore failed.

The iii variable in the below code rezeroes each time a
new page is created and then starts counting again. I had
suggested that it should be required to count up to at
least 10 before a new page can be created irrespective of
whether 3 blank cells are found. To change this value,
don't change the code itself. Instead, just change the
MinLines constant (I arbitrarily selected 10). The purpose
of the constants are as follows:

1) NumBlank: Specifies the minimum number of blank cells
that must be found (in the ColNum column) before a page is
created.
2) FirstRow: Specifies the starting row for the macro.
3) ColNum: Specifies the column that the macro checks.
4) MinLines: Specifies the minimum number of lines that
must be counted before a page can be created irrespective
of whether the required number of blank cells are found.
Rezeroes after a page is created.

Code follows. Correct for wordwrap:-

Const NumBlank As Long = 3
Const FirstRow As Long = 3
Const ColNum As Long = 12
Const MinLines As Long = 10

Sub BreakData3()
Dim wks As Worksheet, wks2 As Worksheet
Dim rng As Range, rng2 As Range
Dim c As Range, cc As Range
Dim i As Long, ii As Long, iii As Long
Dim x As Long
Dim AddPage As Boolean

'On Error Resume Next
Set wks2 = Sheets(Sheets.Count)
x = Cells(Rows.Count, ColNum).End(xlUp).Row
Set rng = Application.Intersect(ActiveSheet.UsedRange, _
Range(Cells(FirstRow, ColNum), Cells(Rows.Count, ColNum)))
Set cc = rng(1)
i = 0: ii = 0: iii = 0: x = 0
Application.ScreenUpdating = False
For Each c In rng
ii = ii + 1
iii = iii + 1
If Trim(c) = "" Then
i = i + 1
If i = NumBlank And iii > MinLines Then
Set rng2 = Range(cc, rng(ii -
NumBlank)).EntireRow
Set cc = c(2)
AddPage = True
End If
ElseIf ii = rng.Count Then
Set rng2 = Range(cc, rng(ii)).EntireRow
AddPage = True
Else
i = 0
End If
If AddPage = True Then
AddPage = False
x = x + 1
iii = 0
Set wks = Sheets.Add(After:=wks2)
wks.Name = "Page " & x
Set wks2 = wks
With wks
Range(.Cells(1, 1), .Cells(rng2.Count,
1)).EntireRow. _
Value = rng2.Value
End With
End If
Next
Application.ScreenUpdating = True
'On Error GoTo 0
End Sub

Regards,
Greg
 
B

Btibert

I dont know if you had this problem, but when the code executes, i
stops saying that the else is without an if, and breaks to the code a
the line

ElseIf ii = rng.Count Then

Ive tried tinkering around with some of the code to remedy thi
problem. When i pasted the code and corrected for word wrap, ther
does not appear to be an error, especially after two attempts.

Furthermore, when I tried to edit the code myself, as it was executin
, the new pages it created were blank. Maybe the problem goes hand i
hand.

Again, thanks for everything.

Broc
 
G

Greg Wilson

It works for me. It sounds like an error when you
corrected for wordwrap. I removed indentations and broke
up the longer lines in order to (hopefully) avoid the need
to correct for wordwrap. Give the below code a try.

As far as strategy is concerned: So long as there is a
reliable condition that can identify the end of a data set
and another to identify the start of a new data set then
code can be written to work off of these. From looking at
your data, it seems that you might want to look for blank
rows instead of blank cells. Perhaps the finding of 3
completely blank rows in a row could be used to identify
the end of a data set. And following this, perhaps the
first nonblank row found could identify the start of a new
data set. This might be more reliable than indidividual
cells. Just a suggestion. Hope the code works.

Const NumBlank As Long = 3
Const FirstRow As Long = 3
Const ColNum As Long = 12
Const MinLines As Long = 10

Sub BreakData4()
Dim wks As Worksheet, wks2 As Worksheet
Dim rng As Range, rng2 As Range
Dim c As Range, cc As Range
Dim i As Long, ii As Long, iii As Long
Dim x As Long
Dim AddPage As Boolean

'On Error Resume Next
Set wks2 = Sheets(Sheets.Count)
x = Cells(Rows.Count, ColNum).End(xlUp).Row
Set rng = Application.Intersect(ActiveSheet. _
UsedRange, Range(Cells(FirstRow, ColNum), _
Cells(Rows.Count, ColNum)))
Set cc = rng(1)
i = 0: ii = 0: iii = 0: x = 0
Application.ScreenUpdating = False
For Each c In rng
ii = ii + 1
iii = iii + 1
If Trim(c) = "" Then
i = i + 1
If i = NumBlank And iii >= MinLines Then
Set rng2 = Range(cc, rng(ii - NumBlank)).EntireRow
Set cc = c(2)
AddPage = True
End If
ElseIf ii = rng.Count Then
Set rng2 = Range(cc, rng(ii)).EntireRow
AddPage = True
Else
i = 0
End If
If AddPage = True Then
AddPage = False
x = x + 1
iii = 0
Set wks = Sheets.Add(After:=wks2)
wks.Name = "Page " & x
Set wks2 = wks
With wks
Range(.Cells(1, 1), .Cells(rng2.Count, 1)).EntireRow. _
Value = rng2.Value
End With
End If
Next
Application.ScreenUpdating = True
'On Error GoTo 0
End Sub

Regards,
Greg
 
Top