Separar por renglones

Hola! Manny_90. Incorpora en un módulo normal la siguiente macro:
_____________________________________

Sub GeneraRangos()
Dim Rng As Range, Celda As Range, RngTmp As Range
Dim ii As Integer, Txt As String, Aaa As Variant

On Error Resume Next
Set Rng = Application.InputBox( _
Prompt:="Seleccione el rango de celdas a procesar", Type:=8)
On Error GoTo 0
If Rng Is Nothing Then Exit Sub

Application.ScreenUpdating = False
Set RngTmp = Rng(1).Offset(0, 1)
For Each Celda In Rng
'Establezco el literal en "Txt"
ii = 1
Do While Asc(Mid(Celda, ii + 1, 1)) > 57: ii = ii + 1: Loop
Txt = Left(Celda, ii)
'Establezco rango numérico en "Aaa(0) y Aaa(1)"
Aaa = Split(Right(Celda, Len(Celda) - ii), "-")

'Llena rango
With RngTmp
If LBound(Aaa) = UBound(Aaa) Then
RngTmp = Txt & Aaa(0)
Set RngTmp = .Offset(1, 0)
Else
Range(RngTmp, .Offset(Aaa(1) - Aaa(0), 0)).ClearContents
RngTmp = Txt & Aaa(0)
Range(RngTmp, .Offset(Aaa(1) - Aaa(0), 0)).DataSeries Type:=xlAutoFill
Set RngTmp = .Offset(1 + Aaa(1) - Aaa(0), 0)
End If
End With

Next Celda

Range(RngTmp, Cells(65536, RngTmp.Column)).Delete xlShiftUp
Application.ScreenUpdating = True
End Sub

_____________________________________

Este código crea a la derecha de la columna seleccionada, el rango de
códigos correspondiente.

Pruébala y comenta.
Saludos, Cacho.

Exelente... Si funciona, pero,

1. Tube que borrar las celdas en blanco para que funcione, en el primer
mensaje (tienes razon) no especifique que hay posibilidad de tener celdas en
blanco.

2. Hay otros datos en otras columnas, el problema es de que al momento de
separar las referencias las nieas no concuerdan con los datos lo que es
necesario insertar el "n" numero de columnas para no tener que desacomodar
los datos.

- trate de agregar una referencia cada vez que este en blanco para poder
borrarlas al final.

- Tambien agrege a tu macro algo para que inserte las columnas pero no me
funciona.

Sub GeneraRangos()
Dim Rng As Range, Celda As Range, RngTmp As Range
Dim ii As Integer, Txt As String, Aaa As Variant

On Error Resume Next
Set Rng = Application.InputBox( _
Prompt:="Seleccione el rango de celdas a procesar", Type:=8)


On Error GoTo 0
If Rng Is Nothing Then Exit Sub

Application.ScreenUpdating = True

ActiveCell.Offset(0, 1).EntireColumn.Insert



Set RngTmp = Rng(1).Offset(0, 1)
For Each Celda In Rng
'Establezco el literal en "Txt"
If Celda = "" Then
Celda = "a0"

Else
End If

ii = 1
Do While Asc(Mid(Celda, ii + 1, 1)) > 57: ii = ii + 1: Loop
Txt = Left(Celda, ii)
'Establezco rango numérico en "Aaa(0) y Aaa(1)"
Aaa = Split(Right(Celda, Len(Celda) - ii), "-")

'Llena rango
With RngTmp
If LBound(Aaa) = UBound(Aaa) Then
RngTmp = Txt & Aaa(0)
Set RngTmp = .Offset(1, 0)
Else
Range(RngTmp, .Offset(Aaa(1) - Aaa(0), 0)).ClearContents
RngTmp = Txt & Aaa(0)
Set RngTmp2 = .Offset(1, 0)
Range(RngTmp2, .Offset((Aaa(1) - Aaa(0)), 0)).EntireRow.Insert
Range(RngTmp, .Offset(Aaa(1) - Aaa(0), 0)).DataSeries Type:=xlAutoFill
Set RngTmp = .Offset(1 + Aaa(1) - Aaa(0), 0)
Set Celda = Celda.Offset((Aaa(1) - Aaa(0)), 0)

End If
End With
Next Celda
Range(RngTmp, Cells(65536, RngTmp.Column)).Delete xlShiftUp
Application.ScreenUpdating = True
ActiveCell.Offset(0, 1).Select
Range(ActiveCell, ActiveCell.End(xlDown)).Select
Selection.Copy
ActiveCell.Offset(0, -1).Select
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False
Application.CutCopyMode = False

End Sub


















"Cacho" wrote:

Hola! Manny_90. Incorpora en un módulo normal la siguiente macro:
_____________________________________

Sub GeneraRangos()
Dim Rng As Range, Celda As Range, RngTmp As Range
Dim ii As Integer, Txt As String, Aaa As Variant

On Error Resume Next
Set Rng = Application.InputBox( _
Prompt:="Seleccione el rango de celdas a procesar", Type:=8)
On Error GoTo 0
If Rng Is Nothing Then Exit Sub

Application.ScreenUpdating = False
Set RngTmp = Rng(1).Offset(0, 1)
For Each Celda In Rng
'Establezco el literal en "Txt"
ii = 1
Do While Asc(Mid(Celda, ii + 1, 1)) > 57: ii = ii + 1: Loop
Txt = Left(Celda, ii)
'Establezco rango numérico en "Aaa(0) y Aaa(1)"
Aaa = Split(Right(Celda, Len(Celda) - ii), "-")

'Llena rango
With RngTmp
If LBound(Aaa) = UBound(Aaa) Then
RngTmp = Txt & Aaa(0)
Set RngTmp = .Offset(1, 0)
Else
Range(RngTmp, .Offset(Aaa(1) - Aaa(0), 0)).ClearContents
RngTmp = Txt & Aaa(0)
Range(RngTmp, .Offset(Aaa(1) - Aaa(0), 0)).DataSeries Type:=xlAutoFill
Set RngTmp = .Offset(1 + Aaa(1) - Aaa(0), 0)
End If
End With

Next Celda

Range(RngTmp, Cells(65536, RngTmp.Column)).Delete xlShiftUp
Application.ScreenUpdating = True
End Sub

_____________________________________

Este código crea a la derecha de la columna seleccionada, el rango de
códigos correspondiente.

Pruébala y comenta.
Saludos, Cacho.

Hola! Manny_90. Veamos si te entendí:
Dices que en lugar de:

R2
R70-72
C74-76
C90
C91
LB93-104

lo que -en realidad tienes es:

R2Dato1.Dato2.Dato3

R70-72Dato1.Dato2.Dato3
C74-76Dato1.Dato2.Dato3

C90...Dato1.Dato2.Dato3
C91...Dato1.Dato2.Dato3
LB93-104..Dato1.Dato2.Dato3

Si esto es así, creo que amerita varias aclaraciones:

a) ¿Hay "algo" a la izquierda de
R2
R70-72
C74-76
C90
C91
LB93-104 ?

b) ¿Cuántas columnas hay a la derecha de
R2
R70-72
C74-76
C90
C91
LB93-104 ?

c) ¿Cómo es -exactamente- que necesitas que quede la distribución de la
información?

Trata de no omitir ningún detalle por "mínimo" que te parezca...

Saludos, Cacho.

Tengo hasta 17 columnas a la derecha y 1 columna a la izq.

Mis datos son estos:



COL-A___COL-B___COL-C
R1: 1___"En blanco"___ ABCD
R2: "En blanco"___R2___fdgdg
R3: "En blanco"___U6____FDSFD
R4: 4___"En Blanco"___fdgdg
R5: "En blanco"___CR1-CR4__SDFS4DF
R6: "En blanco"___C74-C76__FGTT


El resultado que me gustaria obtener es:


COL-A___COL-B___COL-C___COL-D (Con el resultado del macro)
R1: 1___"En blanco"__"Blanco"___ ABCD
R2: "En Blanco"___R2____R2___fdgdg
R3: "En Blanco"___U6___U6____FDSFD
R4: 4___"En Blanco"___"Blanco"___fdgdg
R5: "En Blanco"___ CR1-CR4___CR1__SDFS4DF
R6: "En Blanco"___"En Blanco"___CR2__SDFS4DF
R7: "En Blanco"___"En Blanco"___CR3__SDFS4DF
R8: "En Blanco"___"En Blanco"___CR4__SDFS4DF
R9: "En Blanco"___ C74-C76___C74__FGTT
R10: "En Blanco"___ "En Blanco"___C75__FGTT
R11: "En Blanco"___ "En Blanco"___C76__FGTT


Cada vez que tenga un a referencia con agrupacion, me gustaria que insertara
renglones y llenara la secuencia de referencias. Reviza el codigo que
modifique (del tuyo). Trate de arreglar que cuando una celda estubiera en
blanco esa celda seria a una referencia "x" por ejemplo "A0", de esa manera
el programa seguiria bien.

Cuando llega a una referencia con agrupacion, trate de agregar a tu codigo
algo para que insertara el numero de renglones que tiene la sequencia de las
referencias, pero cuando llega ala linea "Next Celda" PASA A LA CELDA QUE
ESTA EN BLANCO y va a llenar con "A0" en lugar de ir a la siguiente
agrupacion (como en el caso de :

R5: "En blanco"___CR1-CR4__SDFS4DF
R6: "En blanco"___C74-C76__FGTT

Sub GeneraRangos()
Dim Rng As Range, Celda As Range, RngTmp As Range
Dim ii As Integer, Txt As String, Aaa As Variant

On Error Resume Next
Set Rng = Application.InputBox( _
Prompt:="Seleccione el rango de celdas a procesar", Type:=8)


On Error GoTo 0
If Rng Is Nothing Then Exit Sub

Application.ScreenUpdating = True

ActiveCell.Offset(0, 1).EntireColumn.Insert



Set RngTmp = Rng(1).Offset(0, 1)
For Each Celda In Rng
'Establezco el literal en "Txt"
If Celda = "" Then
Celda = "a0"

Else
End If

ii = 1
Do While Asc(Mid(Celda, ii + 1, 1)) > 57: ii = ii + 1: Loop
Txt = Left(Celda, ii)
'Establezco rango numérico en "Aaa(0) y Aaa(1)"
Aaa = Split(Right(Celda, Len(Celda) - ii), "-")

'Llena rango
With RngTmp
If LBound(Aaa) = UBound(Aaa) Then
RngTmp = Txt & Aaa(0)
Set RngTmp = .Offset(1, 0)
Else
Range(RngTmp, .Offset(Aaa(1) - Aaa(0), 0)).ClearContents
RngTmp = Txt & Aaa(0)
Set RngTmp2 = .Offset(1, 0)
Range(RngTmp2, .Offset((Aaa(1) - Aaa(0)), 0)).EntireRow.Insert
Range(RngTmp, .Offset(Aaa(1) - Aaa(0), 0)).DataSeries Type:=xlAutoFill
Set RngTmp = .Offset(1 + Aaa(1) - Aaa(0), 0)
Set Celda = Celda.Offset((Aaa(1) - Aaa(0)), 0)

End If
End With
Next Celda
Range(RngTmp, Cells(65536, RngTmp.Column)).Delete xlShiftUp
Application.ScreenUpdating = True
ActiveCell.Offset(0, 1).Select
Range(ActiveCell, ActiveCell.End(xlDown)).Select
Selection.Copy
ActiveCell.Offset(0, -1).Select
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False
Application.CutCopyMode = False

End Sub



Muchas gracias










"Cacho" wrote:

Hola! Manny_90. Veamos si te entendí:
Dices que en lugar de:

R2
R70-72
C74-76
C90
C91
LB93-104

lo que -en realidad tienes es:

R2Dato1.Dato2.Dato3

R70-72Dato1.Dato2.Dato3
C74-76Dato1.Dato2.Dato3

C90...Dato1.Dato2.Dato3
C91...Dato1.Dato2.Dato3
LB93-104..Dato1.Dato2.Dato3

Si esto es así, creo que amerita varias aclaraciones:

a) ¿Hay "algo" a la izquierda de
R2
R70-72
C74-76
C90
C91
LB93-104 ?

b) ¿Cuántas columnas hay a la derecha de
R2
R70-72
C74-76
C90
C91
LB93-104 ?

c) ¿Cómo es -exactamente- que necesitas que quede la distribución de la
información?

Trata de no omitir ningún detalle por "mínimo" que te parezca...

Saludos, Cacho.

hola, chicos !

segun los datos que expones, el codigo que buscas (en un modulo estandar) es +/- como el siguiente:
ejecutado desde la hoja con los datos en las columnas A, B y C (la columna D sera desplazando la C)

Dim xL As String, xY As Integer, xZ As Integer

Sub MiArregloDeDatos()
Application.ScreenUpdating = False
Dim Fila As Integer, nFilas As Integer
Columns("c").EntireColumn.Insert
For Fila = [b65536].End(xlUp).Row To 2 Step -1
With Range("b" & Fila)
If Len(.Text) Then
xL = "": xY = 0: xZ = 0: Encuentra .Text: nFilas = xZ - xY
If nFilas Then
.Offset(1).Resize(nFilas).EntireRow.Insert
.Offset(, 1).Resize(nFilas + 1).Value = Evaluate( _
"transpose(transpose(""" & xL & """&row(" & xY & ":" & xZ & ")))")
.Offset(, 2).Resize(nFilas + 1).Value = .Offset(, 2).Value
Else: .Offset(, 1) = .Text
End If: End If: End With: Next
End Sub

Private Function Encuentra(Cadena As String)
With CreateObject("vbscript.regexp"): .Pattern = "([A-Z]*)(\d+)"
If .Test(Cadena) Then
With .Execute(Cadena)(0): xL = .SubMatches(0): xY = .SubMatches(1)
End With: .Pattern = "(\d+)$"
With .Execute(Cadena)(0): xZ = .SubMatches(0): End With
End If: End With: End Function

prueba y si cualquier duda (o informacion adicional)... comentas ?
saludos,
hector.

__ OP __

Tengo hasta 17 columnas a la derecha y 1 columna a la izq.
Mis datos son estos:
COL-A___COL-B___COL-C
R1: 1___"En blanco"___ ABCD
R2: "En blanco"___R2___fdgdg
R3: "En blanco"___U6____FDSFD
R4: 4___"En Blanco"___fdgdg
R5: "En blanco"___CR1-CR4__SDFS4DF
R6: "En blanco"___C74-C76__FGTT
El resultado que me gustaria obtener es:
COL-A___COL-B___COL-C___COL-D (Con el resultado del macro)
R1: 1___"En blanco"__"Blanco"___ ABCD
R2: "En Blanco"___R2____R2___fdgdg
R3: "En Blanco"___U6___U6____FDSFD
R4: 4___"En Blanco"___"Blanco"___fdgdg
R5: "En Blanco"___ CR1-CR4___CR1__SDFS4DF
R6: "En Blanco"___"En Blanco"___CR2__SDFS4DF
R7: "En Blanco"___"En Blanco"___CR3__SDFS4DF
R8: "En Blanco"___"En Blanco"___CR4__SDFS4DF
R9: "En Blanco"___ C74-C76___C74__FGTT
R10: "En Blanco"___ "En Blanco"___C75__FGTT
R11: "En Blanco"___ "En Blanco"___C76__FGTT