PDA

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.
.
.

macb
05-05-2005, 07:00 AM
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
.
.