Array usage
Hi Mr Brocklander
The problem was indeed not as trivial as I thought at first. And I hope
I understood this time what you want. If so, the code hereafter should
do the job.
If a sister store exists it is expected in column C, e.g.
A B C
1 101 6
2 101
3 101 8
4 101
5 102
6 103
7 105
8 105
The records 6 103 and 8 105 will be added tot file 101.xls
Option Explicit
Const StoreCol = 1, TerCol = 2, SisCol = 3
Private CurrentSheet As Worksheet, NextRow As Long
Sub BL()
Dim Ro As Long, Cro As Long, Lastrow As Long
Dim LookInCol As Long, Store As Long, SisterStore As Long
Dim Terry As String, LookFor As String
Dim ra As Range
Application.ScreenUpdating = False
ActiveSheet.Cells.Copy
Worksheets.Add
Cells.PasteSpecial xlPasteAll
Application.CutCopyMode = False
Do
Ro = 1
Terry = Cells(Ro, TerCol)
If Len(Terry) = 0 Then Exit Do
Call NewFile(Terry)
Do
Call WriteRow(Ro)
SisterStore = Cells(Ro, SisCol)
Rows(Ro).Delete
LookInCol = TerCol
LookFor = Terry
If SisterStore Then
If WorksheetFunction.CountIf(Columns(StoreCol),
SisterStore) Then
LookFor = SisterStore
LookInCol = StoreCol
End If
End If
Set ra = Columns(LookInCol).Find(LookFor, LookIn:=xlValues,
lookat:=xlWhole)
If ra Is Nothing Then Exit Do
Ro = ra.Row
Loop
Call CloseFile
Loop
With Application
.DisplayAlerts = False
ActiveSheet.Delete
.DisplayAlerts = True
.ScreenUpdating = True
End With
End Sub
Sub NewFile(FileName As String)
Dim s As Worksheet
Set s = ActiveSheet
Set CurrentSheet = Worksheets.Add
CurrentSheet.name = FileName
NextRow = 1
s.Activate
End Sub
Sub WriteRow(r As Long)
Dim s As Worksheet
CurrentSheet.Rows(NextRow).Value = Rows(r).Value
NextRow = NextRow + 1
End Sub
Sub CloseFile()
Dim FilNam As String
With CurrentSheet
FilNam = .name
.Columns(SisCol).Delete xlShiftToRight ' remove the Sister
Store column from the result
.Move ' to a new workbook
End With
ActiveWorkbook.SaveAs FilNam
ActiveWorkbook.Close
End Sub
|