View Full Version : [SOLVED:] VBA code: FILTER DATA
pegbol
05-05-2005, 06:25 AM
.
.
Hello Masters,
I need a VBA code that filter the registers of Sheet1 and send filtered data to Sheet2. : pray2:
I enclose an example in my file.
Thanks so much in advance for your kind assistance.:help
kindest regards,
Pedro.
.
.
Hi
The easiest solution is a Pivot table. You can do it two ways. See the attachment.
Regards
Mac
Bob Phillips
05-05-2005, 07:01 AM
Here you go Pedro, fully tested
Sub ForPedro()
Dim iLastRow As Long
Dim i As Long
Dim iStart As Long
Dim cRows As Long
Dim iTarget As Long
Dim rng As Range
Dim sName As String
iLastRow = Cells(Rows.Count, "A").End(xlUp).Row
Set rng = Range("A1:C" & iLastRow)
rng.Sort Key1:=Range("B2"), _
Order1:=xlAscending, _
Key2:=Range("A2"), _
Order2:=xlAscending, _
Header:=xlYes
sName = Range("B2")
iStart = 2: iTarget = 1: cRows = 1
For i = 2 To iLastRow
If Cells(i, "B").Value <> sName Then
With Worksheets("Sheet2")
With .Cells(iTarget, "A")
.Value = sName
ActiveSheet.Range("B1").Copy
.PasteSpecial Paste:=xlFormats
End With
ActiveSheet.Cells(iStart, "A").Resize(cRows).Copy _
Destination:=Worksheets("Sheet2").Cells(iTarget + 1, "A")
ActiveSheet.Cells(iStart, "C").Resize(cRows).Copy _
Destination:=Worksheets("Sheet2").Cells(iTarget + 1, "B")
With .Cells(iTarget + cRows, "C")
.Formula = "=SUM(B" & iTarget + 1 & ":B" & iTarget + cRows & ")"
ActiveSheet.Range("D" & iLastRow).Copy
.PasteSpecial Paste:=xlFormats
End With
Application.CutCopyMode = False
End With
sName = ActiveSheet.Cells(i, "B").Value
iTarget = iTarget + cRows + 2
cRows = 1
Else
cRows = cRows + 1
End If
Next i
pegbol
05-05-2005, 09:00 AM
.
.
Muchas gracias xld !!!!!!!
For some reason the code doesn't show me the right results.
Please, would you check my attached file and tell me what I am doing wrong?. :banghead:
Again, thanks so much for your kind assistance.:bow:
saludos,
Pedro.
PS. Please, check my Sheet "RESULT NEEDED and compare the results with Sheet2.
.
.
Bob Phillips
05-05-2005, 09:55 AM
Hola Pedro,
muchas apolog?as, errores tontos.
Try this revision
Private iLastRow As Long
Private i As Long
Private iStart As Long
Private cRows As Long
Private iTarget As Long
Private rng As Range
Private sName As String
Sub ForPedro()
Application.ScreenUpdating = False
iLastRow = Cells(Rows.Count, "A").End(xlUp).Row
Set rng = Range("A1:C" & iLastRow)
rng.Sort Key1:=Range("B2"), _
Order1:=xlAscending, _
Key2:=Range("A2"), _
Order2:=xlAscending, _
Header:=xlYes
sName = Range("B2")
iStart = 2: iTarget = 1: cRows = 1
For i = 2 To iLastRow
If Cells(i, "B").Value <> sName Then
OutputDetails
sName = ActiveSheet.Cells(i, "B").Value
iTarget = iTarget + cRows + 2
iStart = i
cRows = 1
Else
cRows = cRows + 1
End If
Next i
OutputDetails
With Worksheets("Sheet2").Cells(iTarget + cRows, "D")
.Formula = "=SUM(C2:C" & iTarget + cRows & ")"
ActiveSheet.Range("D" & iLastRow).Copy
.PasteSpecial Paste:=xlFormats
End With
Application.ScreenUpdating = True
End Sub
Sub OutputDetails()
With Worksheets("Sheet2")
With .Cells(iTarget, "A")
.Value = sName
ActiveSheet.Range("B1").Copy
.PasteSpecial Paste:=xlFormats
End With
ActiveSheet.Cells(iStart, "A").Resize(cRows).Copy _
Destination:=Worksheets("Sheet2").Cells(iTarget + 1, "A")
ActiveSheet.Cells(iStart, "C").Resize(cRows).Copy _
Destination:=Worksheets("Sheet2").Cells(iTarget + 1, "B")
With .Cells(iTarget + cRows, "C")
.Formula = "=SUM(B" & iTarget + 1 & ":B" & iTarget + cRows & ")"
ActiveSheet.Range("D" & iLastRow).Copy
.PasteSpecial Paste:=xlFormats
End With
Application.CutCopyMode = False
End With
End Sub
pegbol
05-05-2005, 10:20 AM
.
.
xld,
Many thanks for your fast reply.
Now the code displays almost the right results.
I only have one problem with "ANGEL". In the database of Sheet1 "ANGEL" has 6 registers.
When I run the code "ANGEL" shows 7 registers in Sheet2. Please, one more time your help.
I apologize if I am a little annoying.
Appreciate your kind assistance.
best and kindest regards,
.
.
Bob Phillips
05-05-2005, 10:33 AM
I only have one problem with "ANGEL". In the database of Sheet1 "ANGEL" has 6 registers.
When I run the code "ANGEL" shows 7 registers in Sheet2. Please, one more time your help.
Most odd, in my tests I still managed to get the correct sums, even with the extra line:eek:
I apologize if I am a little annoying.
Don't be daft, if it were right you could rest in peace:)
Rev 3.
Private iLastRow As Long
Private i As Long
Private iStart As Long
Private cRows As Long
Private iTarget As Long
Private rng As Range
Private sName As String
Sub ForPedro()
Application.ScreenUpdating = False
iLastRow = Cells(Rows.Count, "A").End(xlUp).Row
Set rng = Range("A1:C" & iLastRow)
rng.Sort Key1:=Range("B2"), _
Order1:=xlAscending, _
Key2:=Range("A2"), _
Order2:=xlAscending, _
Header:=xlYes
sName = Range("B2")
iStart = 2: iTarget = 1: cRows = 0
For i = 2 To iLastRow
If Cells(i, "B").Value <> sName Then
cRows = cRows
OutputDetails
sName = ActiveSheet.Cells(i, "B").Value
iTarget = iTarget + cRows + 2
iStart = i
cRows = 1
Else
cRows = cRows + 1
End If
Next i
OutputDetails
With Worksheets("Sheet2").Cells(iTarget + cRows, "D")
.Formula = "=SUM(C2:C" & iTarget + cRows & ")"
ActiveSheet.Range("D" & iLastRow).Copy
.PasteSpecial Paste:=xlFormats
End With
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub
Sub OutputDetails()
With Worksheets("Sheet2")
With .Cells(iTarget, "A")
.Value = sName
ActiveSheet.Range("B1").Copy
.PasteSpecial Paste:=xlFormats
End With
ActiveSheet.Cells(iStart, "A").Resize(cRows).Copy _
Destination:=Worksheets("Sheet2").Cells(iTarget + 1, "A")
ActiveSheet.Cells(iStart, "C").Resize(cRows).Copy _
Destination:=Worksheets("Sheet2").Cells(iTarget + 1, "B")
With .Cells(iTarget + cRows, "C")
.Formula = "=SUM(B" & iTarget + 1 & ":B" & iTarget + cRows & ")"
ActiveSheet.Range("D" & iLastRow).Copy
.PasteSpecial Paste:=xlFormats
End With
Application.CutCopyMode = False
End With
End Sub
pegbol
05-05-2005, 12:04 PM
.
.
Yes!!!!!!!. Now the code works great!!!!! :thumb :clap:
xld my complete gratitude for your valuable help.
thanks and thanks so much.:bow:
:beerchug:
best regards.
Pedro
.
.
Powered by vBulletin® Version 4.2.5 Copyright © 2024 vBulletin Solutions Inc. All rights reserved.