Filter, Delete and Error handling - need help
Hi Jerome
Based on the sample file you sent me, this is what you need.
Sub ReArrangeData()
Dim FilterRng As Range
Dim TargetRng As Range
Dim Field1Array()
Dim Field2 as string
Dim DestCell As Range
Dim sh As Worksheet
Application.ScreenUpdating = False
Set sh = Worksheets("Big Favor")
With sh
Set FilterRng = .Range("A3", .Range("A3").End(xlDown))
Set TargetRng = FilterRng.Offset(1, 1).Resize(FilterRng.Rows.Count
- 1, 1)
Set DestCell = Range("E4")
field2 = .Range("B4")
End With
FilterRng.AdvancedFilter Action:=xlFilterInPlace, unique:=True
ReDim
Field1Array(FilterRng.SpecialCells(xlCellTypeVisib le).Cells.Count - 1)
For Each cell In FilterRng.SpecialCells(xlCellTypeVisible)
Field1Array(c) = cell
c = c + 1
Next
sh.ShowAllData
For c = 1 To UBound(Field1Array)
DestCell = Field1Array(c)
field2 = FilterRng.Find(what:=Field1Array(c),
after:=sh.Range("A3")).Offset(0, 1)
off = 0
FilterRng.AutoFilter field:=1, Criteria1:=DestCell
For Each cell In TargetRng.SpecialCells(xlCellTypeVisible)
If field2 = cell Then
off = off + 1
DestCell.Offset(0, 1) = cell
DestCell.Offset(0, off + 1) = cell.Offset(0, 1)
Else
off = 0
field2 = cell
Set DestCell = DestCell.Offset(1, 0)
DestCell = Field1Array(c)
DestCell.Offset(0, 1) = cell
off = off + 1
DestCell.Offset(0, off + 1) = cell.Offset(0, 1)
End If
Next
Set DestCell = DestCell.Offset(1)
FilterRng.AutoFilter
Next
Application.ScreenUpdating = True
End Sub
Regards,
Per
On 22 Okt., 19:37, Per Jessen wrote:
Which line is highlighted when the error occure (click Debug to see
the line causing the error).
If you prefer you can mail me a sample workbook where I can see what
is happening.
Per
Thanks Per for the reply. I'm still encountering the same error, hope
I can fix it. Thanks again.- Skjul tekst i anførselstegn -
- Vis tekst i anførselstegn -- Skjul tekst i anførselstegn -
- Vis tekst i anførselstegn -
|