Find/Autofilter
KT,
Thanks for your reply, I am glad you made it work.
You can put then in an array for later use, but in this case I think it is
better to use a Collection. See my two examples below:
Sub aaa() 'Array
Dim shArr() As Worksheet
Dim shCount As Long
For Each sh In ThisWorkbook.Sheets
shCount = shCount + 1
ReDim Preserve shArr(1 To shCount)
Set shArr(shCount) = sh
Next
For sh = 1 To UBound(shArr)
Debug.Print shArr(sh).Name
Next
End Sub
Sub bbb() ' Collection
Dim shCol As Collection
Set shCol = New Collection
For Each sh In ThisWorkbook.Sheets
shCol.Add sh
Next
For Each sh In shCol
Debug.Print sh.Name
Next
End Sub
Regards,
Per
"KT" skrev i meddelelsen
...
Thanks for the help Per! I was able to get this to work. I did have to
remove
'If r.Rows.Count 1 Then' in order to get the data to copy.
Debug.Print
r.Rows.Count showed the rows.count as 1, even though there were nearly a
thousand rows visible.
One more question if you (or anyone else) can help - as I create these
sheets, what is the best way to define them (an array?) so that I can
perform
an action on each of these sheets later? I have other sheets in the
workbook, but I will want to be able to reference these specific sheets as
group as in " for each sheet in myArray do 'x' action."
Thanks again.
--
KT
"Per Jessen" wrote:
Hi
Try this:
Dim newSheet As Worksheet
Dim OrgSh As Worksheet
Dim LstRow As Integer
Sub divideThis()
Dim curVariable As String
Dim i As Integer
Dim lstVariable As Integer
Dim f As Variant
Application.ScreenUpdating = False
Set OrgSh = Workbooks("Myworkbook.Xls").Worksheets("OrigSheet" )
LstRow = OrgSh.Range("b" & Rows.Count).End(xlUp).Row
Debug.Print LstRow
With Workbooks("Myworkbook.Xls").Worksheets("Variablesh eet")
lstVariable = .Range("d" & Rows.Count).End(xlUp).Row ' column D
Debug.Print "last variable" & lstVariable
For i = 2 To lstVariable
curVariable = .Cells(i, 4).Value
curVariableName = .Cells(i, 5).Value
Debug.Print "cur " & curVariable & Cells(i,
4).Address(external:=True)
Set f = OrgSh.Range("B2:B" & LstRow).Find(curVariable, _
After:=OrgSh.Range("B" & LstRow), LookIn:=xlValues,
Lookat:=xlWhole)
If Not f Is Nothing Then
'Create new sheet
Set newSheet =
Worksheets.Add(After:=Worksheets(Worksheets.Count) )
newSheet.Name = curVariable & " " & curVariableName
Set f = Nothing
End If
Next i
End With
Application.ScreenUpdating = True
End Sub
Sub copyData(curVariable)
Dim r As Range
With OrgSh
Set r = .Range("B7", .Range("b" & Rows.Count).End(xlUp))
r.AutoFilter field:=1, Criteria1:=curVariable
Debug.Print r.Address(external:=True)
Set r = r.SpecialCells(xlCellTypeVisible)
If r.Rows.Count 1 Then
.Range("a1:k7").Copy
Destination:=Worksheets(curVariable).Range("a1")
r.EntireRow.Copy Destination:=Worksheets(curVariable).Range("a2")
End If
.AutoFilterMode = False
End With
End Sub
Regards,
Per
"KT" skrev i meddelelsen
...
Hi all,
Im having a problem with the following code. The purpose is to create
new
sheets from data on OrigSheet for each variable that matches variable
found
on Variablesheet.
Sub DivideThis misses the *first* variable even though I can confirm
in
the immediate window that it exists. All variables are of same type.
The second problem is when I get to Sub copyData, the sub is being
exited
without filtering/copying the data.
Any input much appreciated! :)
Sub divideThis
Dim curVariable As String
Dim i As Integer
Dim lstVariable As Integer
Dim lstrow As Integer
Application.ScreenUpdating = False
With Workbooks("Myworkbook.Xls").Worksheets("OrigSheet" )
lstrow = .Range("b" & Rows.Count).End(xlUp).Row
End With
Debug.Print lstrow
Debug.Print lstVariable
With Workbooks("Myworkbook.Xls").Worksheets("Variablesh eet") ' create a
new
sheet
for each variable
lstVariable = .Range("d" & Rows.Count).End(xlUp).Row ' column D
Debug.Print "last variable" & lstVariable
For i = 2 To lstVariable
curVariable = .Cells(i, 4).Value
curVariableName = .Cells(i, 5).Value
Debug.Print "cur " & curVariable & Cells(i,
4).Address(external:=True)
If Not
Workbooks("Myworkbook.Xls").Worksheets("OrigSheet" ).Range("b2:b" &
lstrow).Find(curVariable) Is Nothing _
Then Call createSheet(curVariable, curVariableName) << DOESNT
FIND
1ST VARIABLE EVEN THOUGH IT IS IN RANGE. DOES FIND THE REST. NEEDS TO
MATCH
*ENTIRE* CELL CONTENTS.
Next i
End With
End Sub
Sub createSheet(curVariable, curVariableName)
Dim newSheet As Worksheet
With Workbooks("Myworkbook.Xls").Worksheets("OrigSheet" ).Activate
On Error Resume Next
Set newSheet = Worksheets.Add
newSheet.Name = curVariable & " " & curVariableName
Call copyData(curVariable)
'On Error GoTo 0
End With
End Sub
Sub copyData(curVariable)
Dim r As Range
With Worksheets("OrigSheet")
lstrow = .Range("b" & Rows.Count).End(xlUp).Row
'MsgBox lstrow
'.AutoFilterMode = False
.Range("a1:k7").Copy Destination:=Worksheets(curVariable).Range("a1")
AS
FAR AS I GET
.Range(.Range("b8"), .Range("b" & .Rows.Count).End(xlUp)) AUTOFILTER
NEEDS
TO START IN ROW 8. PREV ROWS CONTAIN MERGED CELLS
Debug.Print r.Address(external:=True)
If Application.CountIf(r, curVariable) = 0 Then Exit Sub
.Columns("b7:b" & lstrow).AutoFilter Field:=1, Criteria1:=curVariable
Set r = r.SpecialCells(xlCellTypeVisible)
.AutoFilterMode = False
Range("a1:k7").Copy Destination:=Worksheets(curVariable).Range("a1")
r.EntireRow.Copy Destination:=Worksheets(curVariable).Range("a2")
End With
End Sub
--
KT
|