Macro copie los mismos datos a una hoja nueva los ordene por usuario

Esta es la macro completa

Sub contar()
'Por.Dante Amor
    Application.ScreenUpdating = False
    Set h1 = Sheets("GASTOS")
    Set h2 = Sheets("Hoja1")
    h2.Cells.Clear
    h2.Range("A1:B1") = Array("USUARIOS", "CONTEO")
    For i = 3 To h1.Range("X" & Rows.Count).End(xlUp).Row
        If h1.Cells(i, "X") <> "" Then
            Set b = h2.Columns("A").Find(h1.Cells(i, "X"))
            If Not b Is Nothing Then
                If h2.Cells(b.Row, "C") <> h1.Cells(i, "A") Then
                    h2.Cells(b.Row, "B") = h2.Cells(b.Row, "B") + 1
                    h2.Cells(b.Row, "C") = h1.Cells(i, "A")
                    tot = tot + 1
                End If
            Else
                j = h2.Range("A" & Rows.Count).End(xlUp).Row + 1
                h2.Cells(j, "A") = h1.Cells(i, "X")
                h2.Cells(j, "B") = 1
                h2.Cells(j, "C") = h1.Cells(i, "A")
                tot = tot + 1
            End If
        End If
    Next
    h2.Cells(j + 2, "B") = tot
    h2.Columns("C").Clear
    h1.Select
    For i = h1.Cells(2, Columns.Count).End(xlToLeft).Column To 1 Step -1
        If Application.CountA(h1.Columns(i)) = 0 Then
            h1.Columns(i).Delete
        End If
    Next
    h1.Columns("A:A").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
    h1.Columns("F:F").SpecialCells(xlCellTypeBlanks).FormulaR1C1 = "=R[1]C"
    h1.Columns("F:F").Copy
    h1.Range("F1").PasteSpecial Paste:=xlPasteValues
    u = h1.Range("A" & Rows.Count).End(xlUp).Row
    With h1.Sort
        .SortFields.Clear
        .SortFields.Add Key:=Range("F2:F" & u), SortOn:=xlSortOnValues, _
            Order:=xlAscending, DataOption:=xlSortNormal
        .SetRange Range("A1:I" & u)
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    u = h1.Range("A" & Rows.Count).End(xlUp).Row
    u2 = h1.Range("F" & Rows.Count).End(xlUp).Row
    If u2 > u Then h1.Range("A" & u + 1 & ":I" & u2).Clear
    h1.Range("A1").Select
    Application.ScreenUpdating = True
    MsgBox "Conteo terminado", vbInformation
End Sub

buenas tardes...

Lic. lo que buscaba era que me pasara los mismos datos en otra hoja y eliminacion de fila lo hace en la misma hoja de gasto, pero esta bien tambien exelente solucion hace todo la macro de contar tambien.

2 detalle nada mas

1.- me gustaria que elimine las Columnas (vacias) nombradas Verticales ejemplo A,B,C etc.y No filas numeradas esas que se quede con el espacio.

2.- que las ordene de acuerdo al usuario que todo lo que encuentre en este caso LOPEZ sea  lopez   sin importar fechas  ejemplo.

en espera de su valioso apoyo 

saludos

Sub contar()
'Por.Dante Amor
    Application.ScreenUpdating = False
    Set h1 = Sheets("GASTOS")
    Set h2 = Sheets("Hoja1")
    h2.Cells.Clear
    h2.Range("A1:B1") = Array("USUARIOS", "CONTEO")
    For i = 3 To h1.Range("X" & Rows.Count).End(xlUp).Row
        If h1.Cells(i, "X") <> "" Then
            Set b = h2.Columns("A").Find(h1.Cells(i, "X"))
            If Not b Is Nothing Then
                If h2.Cells(b.Row, "C") <> h1.Cells(i, "A") Then
                    h2.Cells(b.Row, "B") = h2.Cells(b.Row, "B") + 1
                    h2.Cells(b.Row, "C") = h1.Cells(i, "A")
                    tot = tot + 1
                End If
            Else
                j = h2.Range("A" & Rows.Count).End(xlUp).Row + 1
                h2.Cells(j, "A") = h1.Cells(i, "X")
                h2.Cells(j, "B") = 1
                h2.Cells(j, "C") = h1.Cells(i, "A")
                tot = tot + 1
            End If
        End If
    Next
    h2.Cells(j + 2, "B") = tot
    h2.Columns("C").Clear
    h1.Select
    For i = h1.Cells(2, Columns.Count).End(xlToLeft).Column To 1 Step -1
        If Application.CountA(h1.Columns(i)) = 0 Then
            h1.Columns(i).Delete
        End If
    Next
    'h1.Columns("A:A").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
    h1.Columns("F:F").SpecialCells(xlCellTypeBlanks).FormulaR1C1 = "=R[1]C"
    h1.Columns("F:F").Copy
    h1.Range("F1").PasteSpecial Paste:=xlPasteValues
    u = h1.Range("A" & Rows.Count).End(xlUp).Row
    With h1.Sort
        .SortFields.Clear
        .SortFields.Add Key:=Range("F3:F" & u), SortOn:=xlSortOnValues, _
            Order:=xlAscending, DataOption:=xlSortNormal
        .SetRange Range("A2:I" & u)
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    u = h1.Range("A" & Rows.Count).End(xlUp).Row
    u2 = h1.Range("F" & Rows.Count).End(xlUp).Row
    If u2 > u Then h1.Range("A" & u + 1 & ":I" & u2).Clear
    h1.Range("A1").Select
    Application.ScreenUpdating = True
    MsgBox "Conteo terminado", vbInformation
End Sub

Recuerda valorar la respuesta

disculpe de nuevo con este tema Lic. ahora ya NO elimina las  filas numeradas eso si esta bien, lo corri la macro con mas usuarios pero no lo deja por bloque es decir ejemplo que el archivo original  estan los sig. usuarios  

lopez

vera 

galdamez

lopez

vera

galdamez

perea

me gustaria que lo deje ordenado de la sig. manera de acuerdo al orden alfabetico

galdamez

galdamez

lopez

lopez

perea

vera

vera 

espero haberme dado a entender disculpe Lic. las Molestias 

saludos

Sí ordena

Eso fue lo que pediste que ordenara por usuario. Valora esta respuesta y si tienes otra petición crea una nueva pregunta.

buenas noches...

Lic. al agregar la formula nueva que me paso lo aplique en archivo de 1000 datos pero no me los ordeno por usuario, o quizas ingrese mal los codigo  pero de todos me sirve de mucho el conteo por usuario y que no elimina las filas numeradas 

exelente  

saludos

¡Gracias!