Condicion en Macro

02/04/2005 - 22:00 por Oscar | Informe spam

Hola KL

Esta algo largo el codigo, espero que sea entendible...
tambien me gustaria saber que puedo poner en el codigo
para que se detenga, porque al terminar la ultima opcion,
vuelve a comenzar.

Sub Union()
'
' Macro1 Macro
' Macro grabada el 01/04/2005 por ocruz
Dim Asig As String
Dim Canc As String
Dim Res As String
Dim Reg As String
Dim Esp As String
Dim Atn As String
Dim R As Range

Asig = "Asignado"
Canc = "Cancelado"
Res = "Resuelto"
Reg = "Registro"
Esp = "En espera"
Atn = "En atencion"

Range("B50").Select
ActiveSheet.Next.Select

With ActiveSheet.PivotTables("Tabla
dinámica3").PivotFields("SUBESTATUS")
.Orientation = xlRowField
.Position = 2
End With

Dim Rangostar As Range

Range("A4:A100").Select

For Each R In Selection

Selection.Find(What:=Canc, After:=ActiveCell,
LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByRows,
SearchDirection:=xlNext, _
MatchCase:=False).Activate
ActiveCell.Select
ActiveCell.Next.Select
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
ActiveSheet.Previous.Select
Range("B50").Select
Selection.PasteSpecial Paste:=xlValues,
Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False
ActiveSheet.Next.Select
Range("A4:A100").Select

Selection.Find(What:=Reg, After:=ActiveCell,
LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByRows,
SearchDirection:=xlNext, _
MatchCase:=False).Activate
ActiveCell.Select
ActiveCell.Next.Select
Range(Selection, Selection.End(xlToRight)).Select
Selection.Copy
ActiveSheet.Previous.Select
Range("B81").Select
Selection.PasteSpecial Paste:=xlValues,
Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False
ActiveSheet.Next.Select
Range("A4:A100").Select

'Else

Selection.Find(What:=Res, After:=ActiveCell,
LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByRows,
SearchDirection:=xlNext, _
MatchCase:=False).Activate
ActiveCell.Select
ActiveCell.Next.Select
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
ActiveSheet.Previous.Select
Range("B82").Select
Selection.PasteSpecial Paste:=xlValues,
Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False
Range("B62").Select
ActiveSheet.Next.Select
Range("A4:A100").Select
'Else

Selection.Find(What:=Asig, After:=ActiveCell,
LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByRows,
SearchDirection:=xlNext, _
MatchCase:=False).Activate
ActiveCell.Select
ActiveCell.Next.Select
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
ActiveSheet.Previous.Select
Selection.PasteSpecial Paste:=xlValues,
Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False
Range("B62").Select
ActiveSheet.Next.Select
Range("A4:A100").Select
'Else

Selection.Find(What:=Esp, After:=ActiveCell,
LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByRows,
SearchDirection:=xlNext, _
MatchCase:=False).Activate
ActiveCell.Select
ActiveCell.Next.Select
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
ActiveSheet.Previous.Select
Selection.End(xlDown).Select
ActiveCell.Offset(1, 0).Select
Selection.PasteSpecial Paste:=xlValues,
Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False
Range("B62").Select
ActiveSheet.Next.Select
Range("A4:A100").Select
'Else

Selection.Find(What:=Atn, After:=ActiveCell,
LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByRows,
SearchDirection:=xlNext, _
MatchCase:=False).Activate
ActiveCell.Select
ActiveCell.Next.Select
Range(Selection, Selection.End(xlToRight)).Select
Selection.Copy
ActiveSheet.Previous.Select
Selection.End(xlDown).Select
ActiveCell.Offset(1, 0).Select
Selection.PasteSpecial Paste:=xlValues,
Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False
Range("B62").Select
ActiveSheet.Next.Select
Range("A1").Select
End

End Sub

Siga el debate

3 respuestas

Tengo una respuesta

Preguntas similare

Mostrar todos los temas similares

Leer las respuestas

#1 KL

03/04/2005 - 02:28 | Informe spam

Hola Oscar,

Al final no he podido habrir el fichero que me has enviado :-( No se cual es
el problema, pero lo mas probable es que se haya creado en una version de
office mas moderna que la mia (MSO2000) y como usa PivotTables seguramente
hay cosas que no son compatibles con las versiones anteriores.

De todas formas he intentado adivinar que es lo que quires conseguir con tu
macro (y ademas abriendo tu fichero como *.txt adivinar cual es la hoja que
contiene la tabla dinamica) y he escrito el siguiente codigo que ya me diras
si te funciona.

Ojo - es posible que algunos nombres propios (de tablas, hojas, campos, etc)
que usan caracteres con acentos, la ñ, etc. no se hayan copiado bien - tengo
mi sistema configurado en ingles. Por lo tanto quizas necesites corregirlos
en el codigo.

Si te he entendido mal y los rangos a donde copias los valores de la tabla
dinamica no son fijos, tendras que explicarme el criterio segun el cual se
tienen que elegir en cada caso concreto y te modificare el codigo.

Saludos,
KL

'--Inicio Codigo
Sub Test1()
Dim Est As Variant, Dest As Variant
Dim pt As PivotTable, pf As PivotField, rng As Range
Est = Array("Asignado", "Cancelado", "Resuelto", _
"Registro", "En espera", "En atencion")
Dest = Array("B62", "B50", "B82", "B81", "B63", "B64")
Set pt = Sheets("Detalle Admon 1-1-04") _
.PivotTables("Tabla dinámica3")
Set pf = pt.PivotFields("SUBESTATUS")
For i = LBound(Est) To UBound(Est)
On Error Resume Next
Set rng = Intersect(pt.TableRange1, _
pf.PivotItems(Est(i)).DataRange.EntireRow)
On Error GoTo 0
If Not rng Is Nothing Then
With Sheets("Reporte Admon 1-1-04").Range(Dest(i))
.Resize(rng.Rows.Count, rng.Columns.Count) _
.Value = rng.Value
End With
End If
Set rng = Nothing
Next i
End Sub
'--Fin Codigo

Responder a este mensaje

#2 KL

04/04/2005 - 19:06 | Informe spam

Hola,

Aqui va el codigo final.

Saludos,
KL

'--Inicio Codigo
Sub Union()
Dim Est As Variant, Dest As Variant
Dim pt As PivotTable, pf As PivotField
Dim rng As Range, DestRng As Range
Est = Array("Cancelado", "Asignado", "En espera", _
"En atencion", "Registro", "Resuelto")
Dest = Array("B58", "B77", "B77", "B77", "B136", "B136")
Set pt = Sheets("Hoja9") _
.PivotTables("Tabla dinámica3")
Set pf = pt.PivotFields("ESTATU")

Sheets("Reporte Admon 1-1-04"). _
Range("B49:C58,B62:C77,B81:C136").ClearContents
Exit Sub

For i = LBound(Est) To UBound(Est)
On Error Resume Next
Set rng = Intersect(pt.TableRange1, _
pf.PivotItems(Est(i)).DataRange.EntireRow)
On Error GoTo 0
If Not rng Is Nothing Then
Set rng = rng.Offset(0, 1). _
Resize(rng.Rows.Count, rng.Columns.Count - 1)
Set DestRng = Sheets("Reporte Admon 1-1-04") _
.Range(Dest(i)).End(xlUp).Offset(1, 0)
With DestRng
.Resize(rng.Rows.Count, rng.Columns.Count) _
.Value = rng.Value
End With
End If
Set rng = Nothing
Set DestRng = Nothing
Next i
End Sub
'--Fin Codigo

Responder a este mensaje

#3 KL

04/04/2005 - 23:24 | Informe spam

Perdon - version del codigo incorrecta. Aqui esta la buena:

'--Inicio Codigo
Sub Union()
Dim Est As Variant, Dest As Variant
Dim pt As PivotTable, pf As PivotField
Dim rng As Range, DestRng As Range
Est = Array("Cancelado", "Asignado", "En espera", _
"En atencion", "Registro", "Resuelto")
Dest = Array("B58", "B77", "B77", "B77", "B136", "B136")
Set pt = Sheets("Hoja9") _
.PivotTables("Tabla dinámica3")
Set pf = pt.PivotFields("ESTATU")

Sheets("Reporte Admon 1-1-04"). _
Range("B50:C58,B62:C77,B81:C136").ClearContents

For i = LBound(Est) To UBound(Est)
On Error Resume Next
Set rng = Intersect(pt.TableRange1, _
pf.PivotItems(Est(i)).DataRange.EntireRow)
On Error GoTo 0
If Not rng Is Nothing Then
Set rng = rng.Offset(0, 1). _
Resize(rng.Rows.Count, rng.Columns.Count - 1)
Set DestRng = Sheets("Reporte Admon 1-1-04") _
.Range(Dest(i)).End(xlUp).Offset(1, 0)
With DestRng
.Resize(rng.Rows.Count, rng.Columns.Count) _
.Value = rng.Value
End With
End If
Set rng = Nothing
Set DestRng = Nothing
Next i
End Sub
'--Fin Codigo

Siga el debate Respuesta

Responder a este mensaje

Ads by Google

Hacer una pregunta

Tengo una respuesta

Busqueda sugerida