Ok os mando este archivo para que por favor me ayudéis a dejar este código mejor ... yo soy matemático ... solo llevo un par de año con las macros y con vosotros .... y me gusta mucho cuando me dais perspectivas nuevas de cómo hacer las cosas. Como siempre muchas gracias de antemano por vuestra valiosa atención.

deCuaABAse.xlsm

Esta macro convierte el cuadrante de turnos en formato tabla de BD.

Válida para cualquier mes y número de trabajadores.

Sub aBaseDeDatos()
Application.ScreenUpdating = False
With Sheets("DeCuaABase")
   .Range("A8").CurrentRegion.Offset(1).ClearContents
   fila = 8
   For y = .Range("S9").Column To .Cells(8, Columns.Count).End(xlToLeft).Column
      For x = 8 To .Range("R" & Rows.Count).End(xlUp).Row
         fila = fila + 1
         .Range("A" & fila) = .Cells(x, 17)
         .Range("B" & fila) = .Cells(6, y)
         .Range("C" & fila) = .Cells(x, 18)
         .Range("D" & fila) = .Cells(x, y)
      Next
   Next
End With
Application.ScreenUpdating = True
End Sub

 

Hace 8 horas, Antoni dijo:

Esta macro convierte el cuadrante de turnos en formato tabla de BD.

Válida para cualquier mes y número de trabajadores.

Sub aBaseDeDatos()
Application.ScreenUpdating = False
With Sheets("DeCuaABase")
   .Range("A8").CurrentRegion.Offset(1).ClearContents
   fila = 8
   For y = .Range("S9").Column To .Cells(8, Columns.Count).End(xlToLeft).Column
      For x = 8 To .Range("R" & Rows.Count).End(xlUp).Row
         fila = fila + 1
         .Range("A" & fila) = .Cells(x, 17)
         .Range("B" & fila) = .Cells(6, y)
         .Range("C" & fila) = .Cells(x, 18)
         .Range("D" & fila) = .Cells(x, y)
      Next
   Next
End With
Application.ScreenUpdating = True
End Sub

 

Muchas gracias, Antoni qué pasada de MACRO. You are the best!

Tengo algunas preguntas ....

Si solo quisiera añadir un día en particular o un grupo de 3 días de ese mes .... ya que es un pronóstico y si y solo si los trabajadores han asistido y realizado sus turnos pronosticados entonces lo pasaría a base de datos.

Has ahora con mi código puedo por ejemplo pasar un dia:

Pasar la mitad de los trabajadores de 1 dia: 

Pasar un solo trabajador de un día: PERO siempre empezando desde la fila 8 por la manera en la que he realizado el CODIGO

Podemos pasar dos días o tres días cualesquiera siempre que se empiece desde arriba ....

Me gustaría añadir un identificador más a mi código para que de manera selectiva tener la funcionalidad de pasar la celda seleccionada de manera correcta, se 1 o una columna, se empiece por el principio de la columna o a media columna.

EJEMPLO DE FALLO : ya que la fecha lleva CDate de manera que me aseguro de que coja la fecha si o si. Es decir, si inicio el paso de datos desde la celda S10 no funciona.

 

 

VOY A INTENTARLO y si veo que no le saco punta os pido intervención.

Editado el el 17 de agosto3 años por patriciomates

Hace 9 horas, Antoni dijo:

Esta macro convierte el cuadrante de turnos en formato tabla de BD.

Válida para cualquier mes y número de trabajadores.

Sub aBaseDeDatos()
Application.ScreenUpdating = False
With Sheets("DeCuaABase")
   .Range("A8").CurrentRegion.Offset(1).ClearContents
   fila = 8
   For y = .Range("S9").Column To .Cells(8, Columns.Count).End(xlToLeft).Column
      For x = 8 To .Range("R" & Rows.Count).End(xlUp).Row
         fila = fila + 1
         .Range("A" & fila) = .Cells(x, 17)
         .Range("B" & fila) = .Cells(6, y)
         .Range("C" & fila) = .Cells(x, 18)
         .Range("D" & fila) = .Cells(x, y)
      Next
   Next
End With
Application.ScreenUpdating = True
End Sub

 

IMPRESIONANTE VELOCIDAD MATCH 10

Sub aBaseDeDatos()
    Dim IniciarTiempo As Double
    IniciarTiempo = Timer
 
    Dim cel As Range, rng As Range
    Dim txt1 As String, fecha As String, dato As String, buscarv As String
    Dim recuadroVerde As Variant, ultima As Variant
    Dim i As Integer, j As Integer, k As Integer, NroFila As Integer, NroColumna As Integer, recurrencia As Integer

    NroFila = ActiveCell.Row
    NroColumna = ActiveCell.Column
    UsuarioRango = Selection.Address(False, False)
    
    If NroFila = 8 Then i = 2: ElseIf NroFila > 8 Then i = (NroFila - ? + 2: End If

    j = 0
    k = 0

    For Each rng In Range(UsuarioRango).Columns
      Debug.Print vbCr & "columna " & rng.Address
          For Each cel In rng.Cells
            Debug.Print "  - celda " & cel.Address
            recuadroVerde = cel.Address
            ActiveSheet.Range(recuadroVerde).Select
            NroColumna = ActiveCell.Column
    
                If NroColumna = 19 Then
                   NroColumna = NroColumna - 17
                        k = NroColumna
                ElseIf NroColumna Like "*[13579]" Then
                   NroColumna = (NroColumna - 17) + Abs(19 - NroColumna)
                        k = NroColumna
                ElseIf NroColumna Like "*[02468]" Then
                   NroColumna = (NroColumna - 17) + Abs(19 - NroColumna)
                        k = NroColumna
                End If
            
            recurrencia = 1 / 4 * (-1) ^ NroColumna * (-2 * NroColumna + 35 * (-1) ^ NroColumna - 39)
            k = recurrencia
    
            dato = ActiveSheet.Range(recuadroVerde).Value
            txt1 = ActiveSheet.Range(recuadroVerde).Offset(0, k).Value
            fecha = ActiveSheet.Range(recuadroVerde).Offset(-i, 0).Value
            buscarv = "=VLOOKUP(RC[-2],trabajadores,2,FALSE)"
            Debug.Print txt1 & " " & fecha & " " & dato
            
            ultima = ActiveSheet.Cells(Rows.Count, "A").End(xlUp).Row + 1

            With Sheets("DeCuaABase")
                .Range("A" & ultima) = txt1: .Range("B" & ultima) = CDate(fecha): .Range("C" & ultima) = buscarv: .Range("D" & ultima) = dato
            End With
            i = i + 1
            'j = 0
          Next cel
        i = 2: 'j = j + 1
    Next rng
MsgBox Format(Timer - IniciarTiempo, "00.00")
End Sub
 

Ya está solo falta asignar antes de entrar al doble for  el valor de la posición de la selección a la i

deCuaABAse.xlsm

Esta macro te permite seleccionar cualquier número de días y empleados.

Permite selecciones discontinuas.

Para ver como funciona, abre el adjunto y ejecuta la macro respetando la selección.

Sub aBaseDeDatosSelección()
With Sheets("DeCuaABase")
   .Range("A8").CurrentRegion.Offset(1).ClearContents
   fila = 8
   For Each rango In Selection.Areas
      For y = rango.Column To rango.Columns.Count + rango.Column - 1
         For x = rango.Row To rango.Rows.Count + rango.Row - 1
            fila = fila + 1
            .Range("A" & fila) = .Cells(x, 17)
            .Range("B" & fila) = .Cells(6, y)
            .Range("C" & fila) = .Cells(x, 18)
            .Range("D" & fila) = .Cells(x, y)
         Next
      Next
   Next
End With
Application.ScreenUpdating = True
End Sub

 

deCuaABAse.xlsm

Editado el el 18 de agosto3 años por Antoni

YESSSSSSSSSS funciona de miedooooooooo, qué feliz estoy

Funciona muy bien he hecho una lectura por consola ... muchas gracias forever Antoni my God