LinkBack URL
About LinkBacks
I got this from the debruin site. It creates a new worksheet for each different entry in a column or adds the the information if the worksheet is already present. When you run it once it works fine, but if you run it again it will not add the information to the already present sheet. It will just create a new worksheet called sheet50, the next is sheet51 etc.
I've run the code over the exact same sheet twice, so its not that there is any differences in the data. The data I'm sorting by is generally only 3 characters long. Could that be the problem?
On other slight problem I'm having with the same code is that row 1 is copied to every sheet matching or not. I tried to shift 1:1 xlDown, but apparently that doesn't work with advance filter.
Excel 2003
Sub Copy_With_AdvancedFilter_2()
' This sub use the functions LastRow and SheetExists
Dim CalcMode As Long
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim rng As Range
Dim rng2 As Range
Dim cell As Range
Dim Lrow As Long
Dim Lr As Long
Set ws1 = Sheets("Sheet1")
Set rng = ws1.Range("A1:N20000")
'Use a Dynamic range name, http://www.contextures.com/xlNames01.html#Dynamic
'This example filter on the first column in the range (change this if needed)
With Application
CalcMode = .Calculation
.Calculation = xlCalculationManual
.ScreenUpdating = False
End With
With ws1
rng.Columns(2).AdvancedFilter _
Action:=xlFilterCopy, _
CopyToRange:=.Range("IV1"), Unique:=True
'You see that the last two columns of the worksheet are used to make a Unique list
'and add the CriteriaRange.(you can't use this macro if you use the columns)
Lrow = .Cells(Rows.Count, "IV").End(xlUp).Row
.Range("IU1").Value = .Range("IV1").Value
For Each cell In .Range("IV2:IV" & Lrow)
.Range("IU2").Value = cell.Value
If SheetExists(cell.Value) = False Then
Set ws2 = Sheets.Add
On Error Resume Next
ws2.Name = cell.Value
On Error GoTo 0
rng.AdvancedFilter Action:=xlFilterCopy, _
CriteriaRange:=.Range("IU1:IU2"), _
CopyToRange:=ws2.Range("A1"), _
Unique:=False
Else
Set ws2 = Sheets(cell.Text)
Lr = LastRow(ws2)
rng.AdvancedFilter Action:=xlFilterCopy, _
CriteriaRange:=.Range("IU1:IU2"), _
CopyToRange:=ws2.Range("A" & Lr + 1), _
Unique:=False
ws2.Range("A" & Lr + 1).EntireRow.Delete
End If
Next
.Columns("IU:IV").Clear
End With
With Application
.ScreenUpdating = True
.Calculation = CalcMode
End With
End Sub
Function LastRow(sh As Worksheet)
On Error Resume Next
LastRow = sh.Cells.Find(What:="*", _
After:=sh.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlValues, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
On Error GoTo 0
End Function
Function SheetExists(SName As String, _
Optional ByVal WB As Workbook) As Boolean
'Chip Pearson
On Error Resume Next
If WB Is Nothing Then Set WB = ThisWorkbook
SheetExists = CBool(Len(WB.Sheets(SName).Name))
End Function
Register To Reply
Bookmarks