Finding, grouping, then copy/paste to new sheet

[Vacuum Sealed]

Hi All

As the subject states, I need to copy cName.Values from one sheet to
another, although, I don't need every instance of the cName.Values, just one
of each.

I then need it to go back again, find the Count of each cName, and repeat it
to find the Sum of each cName.

Dim SS As Sheet 'Source Sheet
Dim DS As Sheet 'Destination Sheet
Dim myRng As Range
Dim cName As String
Dim Sum_myCrng As Range

Set myRng = Range("F2:F200")
Set Sum_myCrng = Range("R2:R200")

eg

cName: MINS:
ABC Co. 50
XYZ Corp 250
ABC Co. 45
ABC Co. 100

So, for each cName in myRng I need to copy the name into
Sheets("Data").Column ("A").

I use the following to find the first empty cell along Column ("A")...

Columns("A").Find("", Cells(Rows.Count, "A"), xlValues, _
xlWhole, , xlNext).Select

Paste the cName from SS and repeat till one instance of all cNames has been
copied across to DS.

Next

Back to SS, count how many instances of each cName there are in myRng, then
go back to DS paste the Count.Value for each cName in Column ("A").Offset(0,
2) 'which is column C.

Next

Back to SS, Sum each cName there are in Sum_myCrng, then go back to DS paste
the Sum.Value for each cName in Column ("A").Offset(0, 1) 'which is column
B.

Appreciate the assist
As Always!

TIA
Mick.

 

[Claus Busch]

Hi Mick,

Am Sat, 2 Jul 2011 21:58:08 +1000 schrieb Vacuum Sealed:

So, for each cName in myRng I need to copy the name into
Sheets("Data").Column ("A").

I would use advanced filter to copy unique names to DS:

DS.Select
SS.Columns("A:A").AdvancedFilter Action:=xlFilterCopy, _
CopyToRange:=Range("A1"), Unique:=True


Regards
Claus Busch

 

[Vacuum Sealed]

Hi Claus

Thanj you for your reply.

I should have mentioned although I am using 2007, this will be a 2003 WB.

I Compiled the code and it shot up an error on SS.Columns..

Error: Method ot Data Member not found

So I tried it this way and Bingo...!!!! Exactly the same outcome..

Sub Process_Ingleburn()

Dim SSht As Sheets 'Source Sheet
Dim DSht As Sheets 'Destination Sheet
Dim myRng As Range
Dim cName As Variant

Set SSht = Sheets("Ingleburn Data")
Set DSht = Sheets("Ingleburn")
myRng = Range("F:F")

DSht.Select
Columns("A").Find("", Cells(Rows.Count, "A"), xlValues, _
xlWhole, , xlNext).Select
SSht.Select

For Each cName In myRng

With myRng
.AdvancedFilter Action:=xlFilterCopy, _
CopyToRange:=ActiveCell, Unique:=True
End With

Next cName

End Sub
Thx
Mick

 

[Claus Busch]

Hi Mick,

Am Sun, 3 Jul 2011 00:55:11 +1000 schrieb Vacuum Sealed:

For Each cName In myRng

With myRng
.AdvancedFilter Action:=xlFilterCopy, _
CopyToRange:=ActiveCell, Unique:=True
End With

Next cName

you don't need the for...next.
Sub Process_Ingleburn()

Dim SSht As Worksheet 'Source Sheet
Dim DSht As Worksheet 'Destination Sheet
Dim myRng As Range

Set SSht = Sheets("Ingleburn Data")
Set DSht = Sheets("Ingleburn")
Set myRng = SSht.Range("F:F")

Application.Goto DSht.[A1]
myRng.AdvancedFilter Action:=xlFilterCopy, _
CopyToRange:=ActiveCell, Unique:=True

End Sub


Regards
Claus Busch

 

[Vacuum Sealed]

Thx again Claus

Something interesting.

I got this to work, but it had an unusual twist to the end of the code.

Sub Process_Ingleburn()

Dim SSht As Worksheet 'Source Sheet
Dim DSht As Worksheet 'Destination Sheet
Dim myRng As Range
Dim cName As Variant

Set SSht = Sheets("Ingleburn Data")
Set DSht = Sheets("Ingleburn")
Set myRng = Range("F:F")

SSht.Select

With myRng(cName, myRng)
.AdvancedFilter Action:=xlFilterCopy, _
CopyToRange:=ActiveCell, Unique:=True
End With

For Each cName In myRng

DSht.Select
Columns("A").Find("", Cells(Rows.Count, "A"), xlValues, _
xlWhole, , xlNext).Select

Next cName

End Sub


Instead of copying the variant values to the DSht where the first available
empty cell was in Column A, it copied them to SSht.Range("D3752")...LOL...

Any Idea's on how/why it would do that....

BTW:

In your code:

Application.Goto DSht.[A1]
myRng.AdvancedFilter Action:=xlFilterCopy, _
CopyToRange:=ActiveCell, Unique:=True

I need this to search for an empty cell starting from A5, then each time it
loops to the next cName, it will then find the next empty cell along column
again.

Cheers
Mick.

 

[Vacuum Sealed]

Claus

Worked it out, and your code it working very nicely thanks, onto the next
stage.

Thx again.
Mick.

 

[Claus Busch]

Hi Mick,

Am Sun, 3 Jul 2011 01:35:21 +1000 schrieb Vacuum Sealed:

Worked it out, and your code it working very nicely thanks, onto the next
stage.

thank ypu for feedback.
To count in column B and to sum in column C, put in the code:

With DSht
FRow = .Cells(.Rows.Count, 1).End(xlUp).Row + 1
Application.Goto .Range("A" & FRow)
myRng.AdvancedFilter Action:=xlFilterCopy, _
CopyToRange:=ActiveCell, Unique:=True

LRow = .Cells(.Rows.Count, 1).End(xlUp).Row
.Range("B" & FRow + 1).Formula = _
"=COUNTIF('Ingleburn Data'!F:F,A" & FRow + 1 & ")"
.Range("C" & FRow + 1).Formula = _
"=SUMIF('Ingleburn Data'!F:F,A" _
& FRow + 1 & ",'Ingleburn Data'!R:R)"
.Range("B" & FRow + 1 & ":C" & FRow + 1).AutoFill _
Destination:=.Range("B" & FRow + 1 & ":C" & LRow)
End With


Regards
Claus Busch

 

[Vacuum Sealed]

Wow

Thx again there Claus

This is not quite as slick as yours but is working very well.

Turns out I didn't need to find the next empty cell in Column A of DSht as
your code nicely copied all of the Autofilter.selection and pasted it into
A5.

Sweet, thx.

Sub Process_Ingleburn()

Dim SSht As Worksheet 'Source Sheet
Dim DSht As Worksheet 'Destination Sheet
Dim myRng As Range
Dim mySumRng As Range
Dim myCountRng As Range

Set SSht = Sheets("Ingleburn Data")
Set DSht = Sheets("Ingleburn")
Set myRng = SSht.Range("F:F")
Set mySumRng = SSht.Range("P")

Application.Goto DSht.[A5]
myRng.AdvancedFilter Action:=xlFilterCopy, _
CopyToRange:=ActiveCell, Unique:=True

Rows("5:5").Select
Selection.Delete Shift:=xlUp

Range("A4:C200").Sort Key1:=Range("A5"), Order1:=xlAscending, Header:= _
xlGuess, OrderCustom:=1, MatchCase:=False,
Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal

Range("B5").Select

With ActiveCell
.FormulaR1C1 = "=IF(RC[-1]="""","""", SUMIF('Ingleburn
Data'!C[4], RC[-1], 'Ingleburn Data'!C[14])/RC[1])"
End With

Range("B5").Select
Selection.AutoFill Destination:=Range("B5:B200"), Type:=xlFillDefault

Range("C5").Select

With ActiveCell
.FormulaR1C1 = "=IF(RC[-2]="""","""", COUNTIF('Ingleburn
Data'!C[3], RC[-2]))"
End With

Range("C5").Select
Selection.AutoFill Destination:=Range("C5:C200"), Type:=xlFillDefault

Range("C5").Select

End Sub


You will notice there is a Row.Delete @ Row 5, that is because it copies the
header also, so I remove the row and then sort.Ascend the values, then
insert the formulas.

Thx heaps for the pointers in the right direction.

Cheers
Mick.

 

[GS]

Vacuum Sealed explained :

Hi All

As the subject states, I need to copy cName.Values from one sheet to another,
although, I don't need every instance of the cName.Values, just one of each.

I then need it to go back again, find the Count of each cName, and repeat it
to find the Sum of each cName.

Dim SS As Sheet 'Source Sheet
Dim DS As Sheet 'Destination Sheet
Dim myRng As Range
Dim cName As String
Dim Sum_myCrng As Range

Set myRng = Range("F2:F200")
Set Sum_myCrng = Range("R2:R200")

eg

cName: MINS:
ABC Co. 50
XYZ Corp 250
ABC Co. 45
ABC Co. 100

So, for each cName in myRng I need to copy the name into
Sheets("Data").Column ("A").

I use the following to find the first empty cell along Column ("A")...

Columns("A").Find("", Cells(Rows.Count, "A"), xlValues, _
xlWhole, , xlNext).Select

Paste the cName from SS and repeat till one instance of all cNames has been
copied across to DS.

Next

Back to SS, count how many instances of each cName there are in myRng, then
go back to DS paste the Count.Value for each cName in Column ("A").Offset(0,
2) 'which is column C.

Next

Back to SS, Sum each cName there are in Sum_myCrng, then go back to DS paste
the Sum.Value for each cName in Column ("A").Offset(0, 1) 'which is column B.

Appreciate the assist
As Always!

TIA
Mick.

One way that doesn't involve formulas... (watch word wraps)

Sub CollectData1()
Dim vData, vaData()
Dim sTemp As String, i As Integer, lRows As Long
Dim rngNames As Range, rngMinutes As Range
Dim wksSource As Worksheet, wksTarget As Worksheet

Set wksTarget = Sheets("Inglebum")
Set rngNames = Sheets("Inglebum Data").Range("$F$1:$F$200")
Set rngMinutes = Sheets("Inglebum Data").Range("$R$1:$R$200")

'Get unique names
vData = rngNames
For i = 1 To UBound(vData)
If Not InStr(1, sTemp, vData(i, 1), vbTextCompare) > 0 Then _
sTemp = sTemp & "~" & vData(i, 1)
Next
sTemp = Mid$(sTemp, 2): vData = Split(sTemp, "~")

'Get related data
lRows = UBound(vData) + 1: ReDim vaData(1 To lRows, 1 To 3)
vaData(1, 1) = "Name": vaData(1, 2) = "Minutes": vaData(1, 3) =
"Instances"
For i = 2 To lRows
vaData(i, 1) = vData(i - 1)
vaData(i, 2) = Application.WorksheetFunction.SumIf(rngNames,
vData(i - 1), rngMinutes)
vaData(i, 3) = Application.WorksheetFunction.CountIf(rngNames,
vData(i - 1))
Next
wksTarget.Range("$A$1").Resize(UBound(vaData), 3) = vaData
End Sub

 

[Vacuum Sealed]

Hi Garry

This works really well, thank you..

Can this:

vaData(i, 1) = vData(i - 1)
vaData(i, 2) = Application.WorksheetFunction.SumIf(rngNames, vData(i -
1), rngMinutes)
vaData(i, 3) = Application.WorksheetFunction.CountIf(rngNames, vData(i -
1))

be expanded to:

vaData(i, 1) = vData(i - 1)
vaData(i, 2) = Application.WorksheetFunction.SumIf(rngNames, vData(i -
1), rngMinutes) / vaData(i, 3)
vaData(i, 3) = Application.WorksheetFunction.CountIf(rngNames, vData(i -
1))

I was hoping that if possible it would automagically Average(SumTotal) by
the (No. of Visits)

Cheers
Mick.

 

[GS]

Vacuum Sealed explained :

Hi Garry

This works really well, thank you..

Can this:

vaData(i, 1) = vData(i - 1)
vaData(i, 2) = Application.WorksheetFunction.SumIf(rngNames, vData(i -
1), rngMinutes)
vaData(i, 3) = Application.WorksheetFunction.CountIf(rngNames, vData(i -
1))

be expanded to:

vaData(i, 1) = vData(i - 1)

vaData(i, 3) = Application.WorksheetFunction.CountIf(rngNames,
vaData(i, 1))
vaData(i, 2) = Application.WorksheetFunction.SumIf(rngNames,
vaData(i, 1), rngMinutes) / vaData(i, 3)

I was hoping that if possible it would automagically Average(SumTotal) by the
(No. of Visits)

Cheers
Mick.

Well, yes if you move the order of the lines as shown because you need
vaData(i, 3) to contain a value to divide by, otherwise an error
occurs.
*Note* I changed the 2nd/3rd ref to vData(i - 1) to vaData(i, 1).

Also, I suggest you change the column heading to...

vaData(1, 2) = "Avg Minutes"

...in line2 of the 'Get related data' section.

 

[Vacuum Sealed]

Thank you Garry

I will change

Cheers
Mick.

 

[GS]

Mick,
How about 4 columns...

Option Explicit

Sub CollectData_Into4Cols()
Dim vData, vaData()
Dim sTemp As String, i As Integer, lRows As Long
Dim rngNames As Range, rngMinutes As Range
Dim wksSource As Worksheet, wksTarget As Worksheet

Set wksTarget = Sheets("Inglebum")
Set rngNames = Sheets("Inglebum Data").Range("$F$1:$F$200")
Set rngMinutes = Sheets("Inglebum Data").Range("$R$1:$R$200")

'Get unique names
vData = rngNames
For i = 1 To UBound(vData)
If Not InStr(1, sTemp, vData(i, 1), vbTextCompare) > 0 Then _
sTemp = sTemp & "~" & vData(i, 1)
Next
sTemp = Mid$(sTemp, 2): vData = Split(sTemp, "~")

'Get related data
lRows = UBound(vData) + 1: ReDim vaData(1 To lRows, 1 To 4)
vaData(1, 1) = "Name": vaData(1, 2) = "Total Minutes"
vaData(1, 3) = "Total Visits": vaData(1, 4) = "Avg Minutes"
For i = 2 To lRows
vaData(i, 1) = vData(i - 1)
vaData(i, 2) = Application.WorksheetFunction.SumIf(rngNames,
vaData(i, 1), rngMinutes)
vaData(i, 3) = Application.WorksheetFunction.CountIf(rngNames,
vaData(i, 1))
vaData(i, 4) = vaData(i, 2) / vaData(i, 3)
Next
wksTarget.Range("$A$1").Resize(UBound(vaData), 4) = vaData
End Sub

 

[Vacuum Sealed]

Thx again Garry

I managed to find a way around it by swapping 2 & 3 around as you suggested
in your previous post.

Sub Process_Ingleburn_Dels()

Dim vData, vaData()
Dim sTemp As String, i As Integer, lRows As Long
Dim rngNames As Range, rngMinutes As Range
Dim wksSource As Worksheet, wksTarget As Worksheet

Set wksTarget = Sheets("Ingleburn")
Set rngNames = Sheets("Ingleburn Data").Range("$F$1:$F$200")
Set rngMinutes = Sheets("Ingleburn Data").Range("$P$1:$P$200")

'Get unique names

vData = rngNames

For i = 1 To UBound(vData)
If Not InStr(1, sTemp, vData(i, 1), vbTextCompare) > 0 Then _
sTemp = sTemp & "~" & vData(i, 1)

Next

sTemp = Mid$(sTemp, 2): vData = Split(sTemp, "~")

'Get related data
lRows = UBound(vData) + 1: ReDim vaData(1 To lRows, 1 To 3)
vaData(1, 1) = "PICK UP FROM": vaData(1, 2) = "# of VISITS": vaData(1, 3)
= "AVERAGE (MINS)"

For i = 2 To lRows

vaData(i, 1) = vData(i - 1)
vaData(i, 2) = Application.WorksheetFunction.CountIf(rngNames, vData(i -
1))
vaData(i, 3) = Application.WorksheetFunction.SumIf(rngNames, vData(i -
1), rngMinutes) / vaData(i, 2)

Next
wksTarget.Range("$A$19").Resize(UBound(vaData), 3) = vaData

Range("A19").Select
Range("A19:C60").Sort Key1:=Range("A20"), Order1:=xlAscending, Header:=
_
xlGuess, OrderCustom:=1, MatchCase:=False,
Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal

Range("A1").Select

End Sub

Cheers
Mick.

 

[GS]

I was thinking that for report printing you might want to show:

Name, Total Minutes, Total Visits, Avg Mins Per Visit

 

[Vacuum Sealed]

Thx Garry

Fortunate for me, I don't have to make those calls, they ask, I try and give
what they want.

File is now complete and the Manager in question is happy now he has an
Automagic button that does all his thinking for him....lol...

Thx again.
Mick.