Find/Autofilter

[KT]

Hi all,

I’m 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("Variablesheet") ' 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

 

[Per Jessen]

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("Variablesheet")
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]

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.

 

[Per Jessen]

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]

Per -

Thanks for getting me started down the right path ... I appreciate your kind
assistance!