Home |
Search |
Today's Posts |
#1
Posted to microsoft.public.excel.programming
|
|||
|
|||
help with 3 problems??
I am currently using Excel 2007 and have created a dtata storage program. I
have code that will find all the rows that match a certain criteria then copy it to a created sheet. Here are the problems: 1) I need to programmaticlly insert a page break above every 18th row of the created sheet, based on how much data there is to be copied, so if there is say 75 rows of data the code would enter 5 page breaks at rows 18,36,54,72,90. So on and so forth. 2)Once the page breaks are set have the code call Function FormatHeaders at rows 1,18,36,54,72,90. So on and so forth. 3)Then copy all the data starting at the 5th row of every formated page. Here is the code and functions I have currently. Please excuse the lenght of the code I just recently figured out how to create and use modules in VB, so some of the code is quite long and could be reduced if I stored it in modules, any suggestions would be helpful in solving my 3 problems and in reducing the lenght of the code. Private Sub BtnGo_Click() Dim rgMatch As Range '''' range of matches Dim searchFor As String ''' string to search for Dim wsh As Worksheet ''' where to search Dim rgToSearch As Range ''' where to search Dim RgFrom As Range Dim n As Long With Application .ScreenUpdating = False .EnableEvents = False End With 'copies all data that matches 'T' to new sheet searchFor = Me.CbxDept.Text Set wsh = Sheets("Procode") Set rgToSearch = wsh.Range("M:M") Set RgFrom = wsh.Range("A1:M1").EntireColumn n = Int(56 * Rnd + 1) ''' Search all matches Set rgMatch = FindAll(rgToSearch, searchFor & "*", xlValues, xlWhole) ''' Process matches If Not rgMatch Is Nothing Then ''' copy specific columns to new sheet With wsh.Parent.Worksheets.Add ''' copy second column: B-B Application.Intersect(rgMatch.EntireRow, wsh.Range("B:B")).Copy ..Range("B5") ''' copy third column : C-H Application.Intersect(rgMatch.EntireRow, wsh.Range("C:C")).Copy ..Range("H5") ''' copy forth column : D-I Application.Intersect(rgMatch.EntireRow, wsh.Range("D:D")).Copy ..Range("I5") ''' copy fifth column: E-J Application.Intersect(rgMatch.EntireRow, wsh.Range("E:E")).Copy ..Range("J5") ''' copy sixth column: F-K Application.Intersect(rgMatch.EntireRow, wsh.Range("F:F")).Copy ..Range("K5") ''' copy seventh column : G-L Application.Intersect(rgMatch.EntireRow, wsh.Range("G:G")).Copy ..Range("L5") ''' copy eighth column: H-M Application.Intersect(rgMatch.EntireRow, wsh.Range("H:H")).Copy ..Range("M5") ''' copy ninth column: I-N Application.Intersect(rgMatch.EntireRow, wsh.Range("I:I")).Copy ..Range("N5") ''' copy tenth column : J-O Application.Intersect(rgMatch.EntireRow, wsh.Range("J:J")).Copy ..Range("O5") ''' copy eleventh column: K-P Application.Intersect(rgMatch.EntireRow, wsh.Range("K:K")).Copy ..Range("P5") ''' copy twelveth column: L-Q Application.Intersect(rgMatch.EntireRow, wsh.Range("L:L")).Copy ..Range("Q5") ''' copy last column: M-A Application.Intersect(rgMatch.EntireRow, wsh.Range("M:M")).Copy ..Range("A5") Call FormatHeaders '''change the tab color randomly and rename sheet .Tab.ColorIndex = n .Name = searchFor End With End If With Application .ScreenUpdating = True .EnableEvents = True End With End Sub Public Function FindAll(where As Range, what As Variant, lookIn As XlFindLookIn, lookAt As XlLookAt) As Range Dim rgResult As Range Dim cell As Range Dim firstAddr As String With where Set cell = .Find(what, lookIn:=lookIn, lookAt:=lookAt) If Not cell Is Nothing Then firstAddr = cell.Address Do ''' add cell to result range If rgResult Is Nothing Then Set rgResult = cell Else Set rgResult = Application.Union(rgResult, cell) End If ''' find next match Set cell = .FindNext(cell) Loop While Not cell Is Nothing And cell.Address < firstAddr End If End With Set FindAll = rgResult End Function |
Reply |
Thread Tools | Search this Thread |
Display Modes | |
|
|
Similar Threads | ||||
Thread | Forum | |||
aauugghhh...#div/o problems & various average formula problems | Excel Worksheet Functions | |||
OLE Problems | Excel Worksheet Functions | |||
Problems using Add-in | Excel Programming | |||
Problems merging an excel file due to code or file problems? | Excel Programming | |||
XLA problems | Excel Programming |