Forums Últimos mensajes - Powered by IBM
 
Tags Palabras claves

Condicion en Macro

02/04/2005 - 22:00 por Oscar | Informe spam
Ayuda Hacer una pregunta
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
email Siga el debateRespuesta 3 respuestasRespuesta Tengo una respuesta
DRAGON AGE™: INQUISITION – Matadragones
 

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

Preguntas similares

 

Busqueda sugerida :