scripting,count duplicate strings,load the strings together with number dupl sheet2

I am kind of a new with excel and i have been assigned to do some work in xml files.I load them from excel,they are listed in categories.So my task is to write a script that i can get all the categories and number of duplicates in every sheet and write them to a new sheet.For example

Original xml:
Hotel
nails
Beauty/hair
Hotel
nails

The sheet that i have to create vis script must be:
Hotels 2
nails 2
Beayty/hair 1

Any help would be really apreciated

I'm not quite sure why I decided to do this with formula, but...

If you list is in column A on sheet 1 then in cell A1 on sheet 2 you could use the formula:

=IF(ROW(1:1)>SUM(INDEX(--(MATCH(INDIRECT("'Sheet1'!A1:A" & COUNTA(Sheet1!A:A)),INDEX(Sheet1!A:A,0),0)=ROW(INDIRECT("'Sheet1'!A1:A" & COUNTA(Sheet1!A:A)))),0)),"",INDEX(Sheet1!A:A,LARGE(INDEX(ROW(INDIRECT("'Sheet1'!A1:A" & COUNTA(Sheet1!A:A)))*(MATCH(INDIRECT("'Sheet1'!A1:A" & COUNTA(Sheet1!A:A)),Sheet1!A:A,0)=ROW(INDIRECT("Sheet1!A1:A" & COUNTA(Sheet1!A:A)))),0),SUM(INDEX(--(MATCH(INDIRECT("'Sheet1'!A1:A" & COUNTA(Sheet1!A:A)),INDEX(Sheet1!A:A,0),0)=ROW(INDIRECT("'Sheet1'!A1:A" & COUNTA(Sheet1!A:A)))),0))-(ROW(1:1)-1)),0))

And in column B the formula:

=COUNTIF(Sheet1!A:A,A1)

And copy down as far as required.

By the way - having looked at what I've just pasted you'd be insane to do this with formula

wow thanks for the fast reply.I pasted your formula and says i got a formula error!did it work for you?Thanks again!

Yes, it worked for me, but it's really not a very clever way of doing things, I've just got a 'thing' for overly-complicated formula.

The way I'd actually do something like this is, again assuming your data is in sheet 1, column A:

Sub GetUniqueList()

Const lOUTPUT_COLUMN = 1
Const lCOUNT_COLUMN = 2
Const sSTART_CELL = "A1"

Dim wbkOutBook As Workbook
Dim wshOutSheet As Worksheet
Dim wshSource As Worksheet
Dim rngReadCell As Range
Dim rngMatchValue As Range
Dim lWriteRow As Long

Set wshSource = ActiveSheet

Set wbkOutBook = Workbooks.Add
Set wshOutSheet = wbkOutBook.Sheets(1)
Set rngReadCell = wshSource.Range(sSTART_CELL)

With wshOutSheet

  While rngReadCell.Value <> ""

    Set rngMatchValue = .Columns(lOUTPUT_COLUMN).Find(rngReadCell.Value, LookIn:=xlValues, lookat:=xlWhole, MatchCase:=False)
  
    If rngMatchValue Is Nothing Then
      lWriteRow = .Cells(.Rows.Count, lOUTPUT_COLUMN).End(xlUp).Row + 1
      .Cells(lWriteRow, lOUTPUT_COLUMN).Value = rngReadCell.Value
      .Cells(lWriteRow, lCOUNT_COLUMN).Value = 1
    Else
      rngMatchValue.EntireRow.Cells(lCOUNT_COLUMN).Value = rngMatchValue.EntireRow.Cells(lCOUNT_COLUMN).Value + 1
    End If
    
    Set rngReadCell = rngReadCell.Offset(1, 0)
    
  Wend
  
End With

End Sub

I've put this code in a workbook (attached). To use:

1. Open the attached workbook.
2. Open your data sheet with your list of items
3. Press Ctrl-u to run the macro

The macro will create a new workbook, sheet 1 of which will contain your list of unique items, with a count next to each.

Thank you so much Andrew-R!!! It did work!!Just one more problem to resolve,this script is counting all until it finds a gap(from what i know in coding the problem is there While rngReadCell.Value <> ""!!),so in the list i have some have empty cells and after continues some non-empty cells that are not counted in the countcolumn.Is there any other way to defind the end of counting?or maybe i should just order my list first n put the blank at the end and after use the macro script u sended me?
Thanks again you have been very helpfull!

Overwrite the existing code with this modified version...

Sub GetUniqueList()

Const lOUTPUT_COLUMN = 1
Const lCOUNT_COLUMN = 2
Const sSTART_CELL = "A1"

Dim wbkOutBook As Workbook
Dim wshOutSheet As Worksheet
Dim wshSource As Worksheet
Dim rngReadCell As Range
Dim rngMatchValue As Range
Dim lWriteRow As Long
Dim lLastRow As Long

Set wshSource = ActiveSheet

Set wbkOutBook = Workbooks.Add
Set wshOutSheet = wbkOutBook.Sheets(1)
Set rngReadCell = wshSource.Range(sSTART_CELL)

With wshSource
  lLastRow=.Cells(.Rows.Count,.Range(sSTART_CELL).Column).End(xlUp).Row
End With

With wshOutSheet

  While rngReadCell.Row <= lLastRow

    If rngReadCell.Value<>"" Then

      Set rngMatchValue = .Columns(lOUTPUT_COLUMN).Find(rngReadCell.Value, LookIn:=xlValues, lookat:=xlWhole, MatchCase:=False)
  
      If rngMatchValue Is Nothing Then
        lWriteRow = .Cells(.Rows.Count, lOUTPUT_COLUMN).End(xlUp).Row + 1
        .Cells(lWriteRow, lOUTPUT_COLUMN).Value = rngReadCell.Value
        .Cells(lWriteRow, lCOUNT_COLUMN).Value = 1
      Else
        rngMatchValue.EntireRow.Cells(lCOUNT_COLUMN).Value = rngMatchValue.EntireRow.Cells(lCOUNT_COLUMN).Value + 1
      End If

    End If
    
    Set rngReadCell = rngReadCell.Offset(1, 0)
    
  Wend
  
End With

End Sub