Solved: count_data

[oleg_v]

Hi
i need some help with a macro.
in attached file in column "A" there is values
i need a macro that will count how much value of each kind is in
column "A".
and write the values and headers in the next columns

Thanks

[Aussiebear]

Are the unique values to be used as the headers?

[hardlife]

Hi Oleg,

try this :hi:



Sub Makro2()

Dim LastRowA As Integer
Dim LastRowB As Integer
Columns("A:A").Select
Selection.Copy
Range("E1").Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
True, Transpose:=False
Application.CutCopyMode = False
' ActiveSheet.Range("$E:$E").RemoveDuplicates Columns:=1, Header:=xlNo
LastRowA = Range("A" & Rows.Count).End(xlUp).Row
Range("E1:E" & LastRowA).AdvancedFilter Action:=xlFilterInPlace, Unique:=True
LastRowB = Range("E" & Rows.Count).End(xlUp).Row
Range("F2").Select
ActiveCell.FormulaR1C1 = "=COUNTIF(C[-5],RC[-1])"
Selection.AutoFill Destination:=Range("F2:F" & LastRowB)
'Selection.AutoFill Destination:=Range("F2:F1000")
'Range("F2:F7").Select
'Range("F1").Select
ActiveSheet.AutoFilterMode = False
End Sub

[oleg_v]

Yes
The haders with the unique numbers

[oleg_v]

Hi Oleg,

try this :hi:



Sub Makro2()

Columns("A:A").Select
Selection.Copy
Range("E1").Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
True, Transpose:=False
Application.CutCopyMode = False
ActiveSheet.Range("$E:$E").RemoveDuplicates Columns:=1, Header:=xlNo
ActiveCell.FormulaR1C1 = "=COUNTIF(C[-5],RC[-1])"

LastRow = Range("E" & Rows.Count).End(xlUp).Row
Selection.AutoFill Destination:=Range("F2:F" & LastRow)
'Selection.AutoFill Destination:=Range("F2:F1000")
'Range("F2:F7").Select
'Range("F1").Select
End Sub

Hi it does not work properly.

[oleg_v]

Aussiebear ,Hi

I think you understand my idea
thanks

[hardlife]

Hi Oleg,

try this :hi:


Sub Makro2()

Dim LastRowA As Integer
Dim LastRowB As Integer
Columns("A:A").Select
Selection.Copy
Range("D1").Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
True, Transpose:=False
Application.CutCopyMode = False
' ActiveSheet.Range("$E:$E").RemoveDuplicates Columns:=1, Header:=xlNo
LastRowA = Range("A" & Rows.Count).End(xlUp).Row
'Application.CutCopyMode = False
Selection.Sort Key1:=Range("D1"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
'Range("E1:E" & LastRowA).AdvancedFilter Action:=xlFilterInPlace, Unique:=True
Range("D1:D" & LastRowA).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range( _
"E1"), Unique:=True
ActiveSheet.AutoFilterMode = False
LastRowB = Range("E" & Rows.Count).End(xlUp).Row
Range("F1").Select
ActiveCell.FormulaR1C1 = "=COUNTIF(C[-5],RC[-1])"
Selection.AutoFill Destination:=Range("F1:F" & LastRowB)
Columns("D:D").ClearContents

Columns("E:F").Select
Selection.Copy
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False
Application.CutCopyMode = False
Selection.Copy
Range("E1:F" & LastRowB).Select
Application.CutCopyMode = False
Selection.Copy
Range("G1").Select
Selection.PasteSpecial Paste:=xlAll, Operation:=xlNone, SkipBlanks:=False _
, Transpose:=True

End Sub

[mohanvijay]

hi try this



Dim lastrow As Long
Dim repeat_count As Long
Dim repeat_hold(), unique_hold() As Variant
Dim howisit As Boolean
Dim first, aduthu, paste As Long

howisit = False
repeat_count = 1

lastrow = Cells(Rows.Count, 1).End(xlUp).Row

ReDim repeat_hold(1 To lastrow), unique_hold(1 To lastrow) As Variant

For i = 1 To lastrow

If Trim(Cells(i, 1).Value) <> "" Then repeat_hold(i) = Trim(Cells(i, 1).Value)

Next i


For first = 1 To lastrow

For aduthu = 1 To repeat_count

If unique_hold(aduthu) = repeat_hold(first) Then howisit = True

Next aduthu

If howisit = False Then

unique_hold(repeat_count) = repeat_hold(first)
repeat_count = repeat_count + 1

End If

howisit = False

Next first

For paste = 1 To repeat_count - 1

Cells(1, paste + 1).Value = unique_hold(paste)

Next paste

[oleg_v]

tanks for the replayes

i also have a solution that finished working on it just.
Sub DUPLICATENUMBERSAMOUNT()

Dim lngLastRow As Long, lngLoopRow As Long
Dim i As Long, h As Long, last2 As Long, data2 As String, k As Long

Dim lngWriteRow As Long
Dim rngFindRange

lngWriteRow = 1
lngLastRow = Cells(Rows.Count, 11).End(xlUp).Row

For lngLoopRow = lngLastRow To 1 Step -1

With Cells(lngLoopRow, 1)

If WorksheetFunction.CountIf(Range("k1:k" & lngLastRow), .Value) >= 1 Then

If Range("l:l").Find(.Value, lookat:=xlWhole) Is Nothing Then

Cells(lngWriteRow, 12) = .Value
lngWriteRow = lngWriteRow + 1

End If

End If

End With

Next lngLoopRow

last2 = Cells(Rows.Count, 12).End(xlUp).Row
For i = 1 To last2
h = 0
k = 0
data = Sheets("sheet2").Cells(i, 12).Value
Do Until k = lngLastRow
k = k + 1
data2 = Sheets("sheet2").Cells(k, 11).Value

If data = data2 Then
h = h + 1
End If
Loop
Sheets("sheet2").Cells(i, 13).Value = h

Next i
End Sub


what you think?