Saludos amigos del foro, se me presento el siguiente problema:

Tengo una hoja17 de base de datos de muchas preguntas, cuyas opciones de respuesta 1,2,3 y 4  (dispuestas en fila u horizontal) deseo pasarla a la hoja2 "Test" donde estan en configuracion para imprimir (de manera vertical)

Tengo otra hoja4 que es donde estan programadas el numero de preguntas y distribiucion de opciones de respuestas que se va a plantear para la hoja Test

Pare enviar las opciones de respuestas de la hoja17 (Hoja17.Range("H3:K3")) a la hoja2 en base a la hoja4, uso el siguiente codigo busco el punto de intercepcion basada en el numero de pregunta que este horizontalmente en la hoja4 (a partir de la columna 4 a la 13) sobre la hoja17 de la lista de preguntas ( estos numeros estan en la columna2, continuos)

se intercepta con hoja4 COL2 = 18 To 66 saltos de 4 consecutivos y salta1

En la hoja2 se copiaran en la columna3 fila12 (4 filas consecutivas) luego se salta 3 y nuevamente 4 consecutivas para la pregunta 2 y asi sucesivamente (es decir cada 7 para cada fila de opcion)

With Hoja2

'PREGUNTA 1

fil = 12

For COL2 = 18 To 21

iop = Cells(Hoja17.Range("B5:B1000").Find(What:=Hoja4.Cells(10, 4), LookAt:=xlWhole).Row, _

      Hoja17.Range("H3:K3").Find(What:=Hoja4.Cells(10, COL2), LookAt:=xlWhole).Column).Select

.Cells(fil, 3) = Selection.Offset(0, 0)

fil = fil + 1

Next COL2

End With

Me funciona bien, solo para la primera pregunta.

Trate de armar para 10 preguntas, pero alli encambio me falla a partir de la 2...

Ademas no encuentro como simplificar el bucle. para las 10 preguntas.

Este es el codigo para las 10 preguntas totales:

Sub RecontruirOppreguntas()

Dim COL2 As Integer

Dim fil As Integer

Dim iop As Range

Application.ScreenUpdating = True

With Hoja2

'PREGUNTA 1

fil = 12

For COL2 = 18 To 21

iop = Cells(Hoja17.Range("B5:B1000").Find(What:=Hoja4.Cells(10, 4), LookAt:=xlWhole).Row, _

      Hoja17.Range("H3:K3").Find(What:=Hoja4.Cells(10, COL2), LookAt:=xlWhole).Column).Select

.Cells(fil, 3) = Selection.Offset(0, 0)

fil = fil + 1

Next COL2

End With

With Hoja2

'PREGUNTA 2

fil = 19

For COL2 = 23 To 26

iop = Cells(Hoja17.Range("B5:B1000").Find(What:=Hoja4.Cells(10, 5), LookAt:=xlWhole).Row, _

      Hoja17.Range("H3:K3").Find(What:=Hoja4.Cells(10, COL2), LookAt:=xlWhole).Column).Select

.Cells(fil, 3) = Selection.Offset(0, 0)

fil = fil + 1

Next COL2

End With

With Hoja2

'PREGUNTA 3

fil = 26

For COL2 = 28 To 31

iop = Cells(Hoja17.Range("B5:B1000").Find(What:=Hoja4.Cells(10, 6), LookAt:=xlWhole).Row, _

      Hoja17.Range("H3:K3").Find(What:=Hoja4.Cells(10, COL2), LookAt:=xlWhole).Column).Select

.Cells(fil, 3) = Selection.Offset(0, 0)

fil = fil + 1

Next COL2

End With

With Hoja2

'PREGUNTA 4

fil = 33

For COL2 = 33 To 36

iop = Cells(Hoja17.Range("B5:B1000").Find(What:=Hoja4.Cells(10, 7), LookAt:=xlWhole).Row, _

      Hoja17.Range("H3:K3").Find(What:=Hoja4.Cells(10, COL2), LookAt:=xlWhole).Column).Select

.Cells(fil, 3) = Selection.Offset(0, 0)

fil = fil + 1

Next COL2

End With

With Hoja2

'PREGUNTA 5

fil = 40

For COL2 = 38 To 41

iop = Cells(Hoja17.Range("B5:B1000").Find(What:=Hoja4.Cells(10, 8), LookAt:=xlWhole).Row, _

      Hoja17.Range("H3:K3").Find(What:=Hoja4.Cells(10, COL2), LookAt:=xlWhole).Column).Select

.Cells(fil, 3) = Selection.Offset(0, 0)

fil = fil + 1

Next COL2

End With

With Hoja2

'PREGUNTA 6

fil = 47

For COL2 = 43 To 47

iop = Cells(Hoja17.Range("B5:B1000").Find(What:=Hoja4.Cells(10, 9), LookAt:=xlWhole).Row, _

      Hoja17.Range("H3:K3").Find(What:=Hoja4.Cells(10, COL2), LookAt:=xlWhole).Column).Select

.Cells(fil, 3) = Selection.Offset(0, 0)

fil = fil + 1

Next COL2

End With

With Hoja2

'PREGUNTA 7

fil = 54

For COL2 = 49 To 53

iop = Cells(Hoja17.Range("B5:B1000").Find(What:=Hoja4.Cells(10, 10), LookAt:=xlWhole).Row, _

      Hoja17.Range("H3:K3").Find(What:=Hoja4.Cells(10, COL2), LookAt:=xlWhole).Column).Select

.Cells(fil, 3) = Selection.Offset(0, 0)

fil = fil + 1

Next COL2

End With

With Hoja2

'PREGUNTA 8

fil = 61

For COL2 = 55 To 59

iop = Cells(Hoja17.Range("B5:B1000").Find(What:=Hoja4.Cells(10, 11), LookAt:=xlWhole).Row, _

      Hoja17.Range("H3:K3").Find(What:=Hoja4.Cells(10, COL2), LookAt:=xlWhole).Column).Select

.Cells(fil, 3) = Selection.Offset(0, 0)

fil = fil + 1

Next COL2

End With

With Hoja2

'PREGUNTA 9

fil = 68

For COL2 = 61 To 65

iop = Cells(Hoja17.Range("B5:B1000").Find(What:=Hoja4.Cells(10, 12), LookAt:=xlWhole).Row, _

      Hoja17.Range("H3:K3").Find(What:=Hoja4.Cells(10, COL2), LookAt:=xlWhole).Column).Select

.Cells(fil, 3) = Selection.Offset(0, 0)

fil = fil + 1

Next COL2

End With

With Hoja2

'PREGUNTA 10

fil = 75

For COL2 = 67 To 71

iop = Cells(Hoja17.Range("B5:B1000").Find(What:=Hoja4.Cells(10, 13), LookAt:=xlWhole).Row, _

      Hoja17.Range("H3:K3").Find(What:=Hoja4.Cells(10, COL2), LookAt:=xlWhole).Column).Select

.Cells(fil, 3) = Selection.Offset(0, 0)

fil = fil + 1

Next COL2

End With

Application.ScreenUpdating = True

End Sub

Por favor si me pueden colabrorar revisando esta macro para resolver este problema

Agradezco anticipadamente su apoyo