Copiar datos eliminando filas vacías

Por lo que pude entender esto es lo que usted necesita:
contador1 = 0
    contador2 = 0
    For Each c In Worksheets("Diario").Range("Q10:Q40")
        If c.Value <> "" Then
            Worksheets("Diario").Cells(100 + contador2, 17).Value = Worksheets("Diario").Cells(10 + contador1, 17).Value
            Worksheets("Diario").Cells(100 + contador2, 18).Value = Worksheets("Diario").Cells(10 + contador1, 18).Value
            contador2 = contador2 + 1
        End If
        contador1 = contador1 + 1
    Next c

En primer lugar el rango indicado no es el corrector, debería de ser (Q10:S40).
Lo he cambiado y no funciona, no elimina las celdas vacías y al copiar los datos en
Q100, el primer dato es la suma del total, hasta ahora yo funcionaba con una macro
para hacer lo mismo en el rango (A10:R40) y pegarlos en (A55) que es el siguiente y me funciona correctamente
Sub locomocion()
ActiveWindow.LargeScroll Down:=-1
Selection.Autofilter Field:=1, Criterial:=">0", Operator:=xlAnd
Range("A10:R40").Select
Selection.Copy
Range("A55").Select
ActiveSheet.Paste
Application.CutCopyMode=False
ActiveWindow.SmallScroll Down:=-9
Selection.Autofilter Field:=1
End Sub
A esta macro le cambio el rango a copiar y el de destino y no me funciona, si te es más fácil corregir esta ajustadola a los rangos ("Q10:S40") y pegarlos en Q100.
Gracias por anticipado