Eliminar filas dependiendo de valor de celda

Hola Ivan,

que no te asuste el lenguaje (que he usado)!!!!!
conociendo mi nivel y viendo tu solución a mis dudas verás que, por
complicado que suene... ;-)
pero tienes razón en que es nuevo tema y debe ser nuevo hilo.

MarianoB

Cuando digo decía "trasponer" me refería a datos (no filas enteras).
Algo así:

original:
asd ddd fgh dfg 34 dfga
asd ddd fgh dfg 34 dfgb
asd ddd fgh dfg 34 dfgc
asd ddd fgh dfg 34 dfgd
asd ddd fgh dfg 34 dfge
asd ddd fgh dfg 34 dfgf
sdg dfm jklj fkq 23 erta
sdg dfm jklj fkq 23 ertb
sdg dfm jklj fkq 23 ertc

traspuesto:
asd ddd fgh dfg 34 dfga dfgb dfgc dfgd dfge dfgf
sdg dfm jklj fkq 23 erta ertb ertc

pasando de 12 filas a 2 habiendo eliminado las filas 2repetidas"
excepto los datos que me interesaban (solo me interesaba el último
campo que es el que variaba) de las "repetidas" que los añadía como
nuevos campos en el lado derecho de cada una de las primeras filas
"repetidas".

salu2

MarianoB

hola Mariano

ve echandole un ojo, le falta rematar la ultima fila y si hay mas de
250 repeticiones de uno de ellos te dara error por desbordamiento

esta echo para -> columnas con datos rep. "a:e" , datos variables -> f

hazlo sobre una copia de la Hoja ->ojo al nombre de las hojas (lo copia
en una 2ª y la 1ª la elimina), adaptalos

no lo he probado casi, pero para que vayas mirando

Sub testFingirTransponer2()
Dim celda As Range, criterio As String, c As Byte, tarda, ccc As Byte
Dim esIgual As Boolean, cc As Byte, f As Long, ff As Long
Application.ScreenUpdating = False
With Worksheets("testTransponer")
If .[a2] = "" Then Exit Sub
If .AutoFilterMode Then .AutoFilterMode = False
f = .[a65536].End(xlUp).Row
For Each celda In .Range("a2:a" & f)
With celda
criterio = .Value
.CurrentRegion.AutoFilter _
field:=1, _
Criteria1:=criterio
For cc = 2 To 5
criterio = celda.Cells(1, cc)
With Cells.SpecialCells(xlCellTypeVisible)
If .Rows.Count > 1 Then
.AutoFilter _
field:=cc, _
Criteria1:=criterio
End If
End With
Next
End With
With .AutoFilter.Range
If .Rows.Count > 1 Then
.Offset(1).Resize(.Rows.Count - 1, Columns.Count).Copy
With Worksheets("ocuTrans")
ff = .[a65536].End(xlUp).Row + 1
.Paste .Range("a" & ff)
ccc = 7
For c = ff To .[a65536].End(xlUp).Row
.Cells(ff, ccc) = .Cells(c, 6)
ccc = ccc + 1
Next
.Range("a" & ff + 1 & ":a" & .[a65536].End(xlUp).Row +
1).EntireRow.Delete
End With
If .Rows.Count > 1 Then _
.Offset(2).Resize(.Rows.Count - 1,
Columns.Count).EntireRow.Delete
End If
End With
If .AutoFilterMode Then .AutoFilterMode = False
Next
If .[a2] <> "" Then
With .Range("a2:a" & .[a65536].End(xlUp).Row).EntireRow
.Copy Worksheets("ocuTrans").[a65536].End(xlUp).Offset(1, 0)
With Worksheets("ocuTrans")
ff = .[a65536].End(xlUp).Row + 1
ccc = 7
For c = ff To .[a65536].End(xlUp).Row
.Cells(ff, ccc) = .Cells(c, 6)
ccc = ccc + 1
Next
.Range("a" & ff + 1 & ":a" & .[a65536].End(xlUp).Row +
1).EntireRow.Delete
If .AutoFilterMode Then .AutoFilterMode = False
End With
.Delete
End With
End If
.Columns.AutoFit
End With
End Sub

no tengo tiempo de mas

es un poco chapuza y sin refinar ni quitar la basura

un saludo
Ivan

hola Mariano

este es el codigo ya depurado (a mi nivel) que parece funcionar (ojo al
desbordamiento) pero que a nivel de velocidad no creo que te sirva de
mucho ( para 6 columnas con datos, y 12500 filas aprox tarda +/- 36 sg
con ciento y algo coincidencias para cada registro

bueno, aunque no fuera muy util, si ha resultado un buen ejercicio por
estos pagos

un saludo y hasta pronto
Ivan

PD si decides probarlo, esta hecho para que los datos (digamos) a
igualar esten en las columnas de la A a la E y los datos que quieres
transponer en la F, y debes tener dos hojas llamadas Hoja1 y Hoja2.
Pega los datos en la hoja1 con encabezados en la fila 1 y los datos
empezando en la 2 y en la hoja 2 le pones solamente los encabezados en
la fila 1. en la ventana inmediato podras ver el tiempo que tarda

y ya sabes, si tienes mas de 250 coincidencias para un mismo registro,
desbordamiento, excedes el nº de columnas

Sub testFingirTransponer4()
Dim celda As Range, criterio As String, tarda
Dim cc As Byte, f As Long, ff As Long, colN As Byte
Application.ScreenUpdating = False
tarda = Timer
With Worksheets("Hoja1")
If .[a2] = "" Then Exit Sub
If .AutoFilterMode Then .AutoFilterMode = False
f = .[a65536].End(xlUp).Row
For Each celda In .Range("a2:a" & f)
criterio = celda.Value
celda.CurrentRegion.AutoFilter _
field:=1, _
Criteria1:=criterio
For cc = 2 To 5
criterio = celda.Cells(1, cc)
With .Cells.SpecialCells(xlCellTypeVisible)
If .Rows.Count > 1 Then
.AutoFilter _
field:=cc, _
Criteria1:=criterio
End If
End With
Next
With .AutoFilter.Range
If .Rows.Count > 1 Then
.Offset(1).Resize(.Rows.Count - 1, Columns.Count).Copy
With Worksheets("Hoja2")
ff = .[a65536].End(xlUp).Row + 1
.Paste Worksheets("Hoja2").Range("a" & ff)
For colN = 1 To .[f65536].End(xlUp).Row - ff
.Cells(ff, colN + 6) = .Cells(ff + colN, 6)
Next
.Range("f" & ff + 1 & ":f" &
.[f65536].End(xlUp).Row).EntireRow.Delete
.Columns.AutoFit
End With
End If
.Offset(1).Resize(.Rows.Count - 1,
Columns.Count).EntireRow.Delete
End With
If .AutoFilterMode Then .AutoFilterMode = False
Next
If .AutoFilterMode Then .AutoFilterMode = False
.Columns.AutoFit
End With
tarda = Timer - tarda
Debug.Print "Tarda -> " & tarda
End Sub

Hola Ivan:
La macro que nos has facilitado a Mariano y al grupo me parece estupenda y
funciona muy bien.
Investigando en la posibilidad de evitar mas eliminaciones de filas que
apuntabas igualando los
valores a cero (0) mediante 'Value=0, quitando la coma, he estado enredando
y no lo consigo.
¿Hay que cambiar de sitio, bucle, o otra cosa el 'Value=0 ? Supongo que
algo de eso sera , pero
se poco de macros y VB.
Gracias por adelantado, Gavillas.

"Ivan" escribió en el mensaje
news:

hola Mariano

esto hace lo que comentas (se supone que la columna que contiene los
valores para eliminar filas es la "AL", si no es asi cambialo en el
codigo),

Tambien es posible que una vez que hayas hecho una eliminacion no
quieras que esas filas vuelvan a entrar en una eliminacion (sino, si
volvieras a darle a la macro te volveria a eliminar filas hasta dejar
solo las que contengan 0), para ello podrias igualar a 0 los valores de
eliminacion. En la macro hay una instruccion como comentario ( 'Value=0
con comilla simple delante de la linea de codigo) que realiza esto, si
es lo que quieres quita la comilla

Sub EliminarNroFilas()
Dim f As Long
For f = 2 To [a65536].End(xlUp).Row
With Range("al" & f)
If .Value > 0 Then
Select Case .Value
Case 1: .Offset(1, 0).EntireRow.Delete
Case Else
Range("al" & f + 1 & ":al" & f + .Value) _
.EntireRow.Delete
End Select
' .Value = 0
End If
End With
Next

prueba con copias

un saludo y hasta pronto
Ivan