Ciclo para eliminar celdas con números

 

Macro para eliminar números y texto en mayúsculas de una columna

De la columna Q eliminar las celdas que contengan números y las celdas que contengan todo el texto en mayúsculas.

-------------------

Sub eliminar_numeros_texto_mayusculas()
  Dim a As Variant
  Dim i As Long, j As Long, k As Long, lr As Long
  Dim rng As Range
  Dim encontrado As Boolean
  Dim caracter As String
  
  lr = Range("Q" & Rows.Count).End(3).Row
  a = Range("Q1:Q" & lr).Value
  Set rng = Range("Q" & lr + 1)
  
  For i = 1 To UBound(a)
  
    encontrado = False
    For k = 0 To 9
      If InStr(1, a(i, 1), k) > 0 Then
        'Encontró un número, entonces elimina la celda
        Set rng = Union(rng, Range("Q" & i))
        encontrado = True
        Exit For
      End If
    Next
    
    If encontrado = False Then
      For k = 97 To 122
        caracter = Chr(k)
        If InStr(1, a(i, 1), Chr(k)) > 0 Then
          'si existe una minúscula, entonces no elimina la celda
          encontrado = True
          Exit For
        End If
      Next
    
      If encontrado = False Then
        'si es falso, entonces son puras mayúculas, entonces elimina la celda
        Set rng = Union(rng, Range("Q" & i))
      End If
    End If
  Next
  
  'elimina las encontradas
  rng.ClearContents
End Sub

------------------

Ciclo For Para Poner Días

 

Generar días del mes cada tres renglones poner el siguiente día.

Generar los días del mes dejar tres renglones y en cuarto poner el día del mes en una hoja de excel

Por ejemplo:

Fila uno: miércoles 1 de noviembre de 2023

Fila dos.

Fila tres

Fila cuatro

Fila cinco: jueves 2 de noviembre del 2023

Macro:

------------------------

Sub ponerdias()
  Dim dia As Long, finmes As Long, n As Long
  
  n = 1
  finmes = Day(WorksheetFunction.EoMonth(Date, 0))
  For dia = 1 To finmes
    Range("A" & n).Value = DateSerial(Year(Date), Month(Date), dia)
    n = n + 4
  Next
End Sub

------------------------

Para cualquier mes, cambia "dic" por el mes que necesitas

-----------------------

Sub ponerdias()
  Dim dia As Long, finmes As Long, n As Long
  Dim fecha As Date
  
  fecha = CDate("01/dic/2023")
  n = 1
  finmes = Day(WorksheetFunction.EoMonth(fecha, 0))
  For dia = 1 To finmes
    Range("A" & n).Value = DateSerial(Year(fecha), Month(fecha), dia)
    n = n + 4
  Next
End Sub

-----------------------

Macro para copiar datos de un libro a otro utilizando Matrices

El uso de matrices es de las mejores prácticas para realizar los procesos en memoria con una gran cantidad de datos.

En este ejemplo, la macro copia los datos de las columnas del libro 1 y las pega en el libro 2, pero en el libro 2 las columnas están en diferente orden.

En el vídeo también explico la manera de utilizar el diccionario (Dictionary) para indexar los títulos de las columnas. 

Código para copiar Datos:

---

Sub Comparar_Datos()
  Dim sh1 As Worksheet, sh2 As Worksheet
  Dim dic As Object
  Dim a As Variant, b As Variant
  Dim i As Long, j As Long, lr As Long, lc As Long
  
  Set dic = CreateObject("Scripting.Dictionary")
  Set sh1 = Workbooks("Libro1").Sheets("Matriz")
  Set sh2 = Workbooks("Libro2").Sheets("Datos")
  
  lr = sh1.Range("A:D").Find("*", , xlValues, xlPart, xlByRows, xlPrevious).Row
  lc = sh1.Cells(4, Columns.Count).End(1).Column
  a = sh1.Range("A4", sh1.Cells(lr, lc)).Value
  b = sh2.Range("A4").Resize(UBound(a, 1), UBound(a, 2)).Value
    
  'recorre las columnas del libro2 para armar el diccionario
  For j = 1 To UBound(b, 2)
    dic(b(1, j)) = j  'almacena el título en el diccionario y como item la columna
  Next
  
  'recorre la matriz 'a' por columna, busca la columna en el diccionario
  'y en esa columna almacena los datos
  For j = 1 To UBound(a, 2)
    If dic.exists(a(1, j)) Then
      'pasa los datos de la matriz 'a' a la matriz 'b'
      For i = 2 To UBound(a, 1)
        b(i, dic(a(1, j))) = a(i, j)
  
        'sh2.Range("A4").Resize(UBound(b, 1), UBound(b, 2)).Value = b
      
      Next
    End If
  Next
    
  sh2.Range("A4").Resize(UBound(b, 1), UBound(b, 2)).Value = b
End Sub

---

Macro para copiar en 2 columnas diferentes en el destino:

---

Sub Comparar_Datos_2()

'copiar en dos columnas diferentes

  Dim sh1 As Worksheet, sh2 As Worksheet

  Dim dic As Object

  Dim a As Variant, b As Variant

  Dim i As Long, j As Long, lr As Long, lc As Long

  Dim js As String, col As Variant

  

  Set dic = CreateObject("Scripting.Dictionary")

  Set sh1 = Workbooks("Libro1").Sheets("Matriz")

  Set sh2 = Workbooks("Libro2").Sheets("Datos")

  

  lr = sh1.Range("A:D").Find("*", , xlValues, xlPart, xlByRows, xlPrevious).Row

  lc = sh1.Cells(4, Columns.Count).End(1).Column

  a = sh1.Range("A4", sh1.Cells(lr, lc)).Value

  

  lc = sh2.Cells(4, Columns.Count).End(1).Column      'columnas en libro2

  b = sh2.Range("A4").Resize(UBound(a, 1), lc).Value

    

  'recorre las columnas del libro2 para armar el diccionario

  For j = 1 To UBound(b, 2)

    If Not dic.exists(b(1, j)) Then

      dic(b(1, j)) = j  'almacena el título en el diccionario y como item la columna

    Else

      js = dic(b(1, j)) & "|" & j

      dic(b(1, j)) = js 'almacena otra columna en caso de repetirse el mismo título

    End If

  Next

  

  'recorre la matriz 'a' por columna, busca la columna en el diccionario

  'y en esa columna almacena los datos

  For j = 1 To UBound(a, 2)

    If dic.exists(a(1, j)) Then

      'pasa los datos de la matriz 'a' a la matriz 'b'

      For Each col In Split(dic(a(1, j)), "|")    'para cada columna, incluso si hay repetidas

        For i = 2 To UBound(a, 1)

          b(i, col) = a(i, j)

        Next

      Next

    End If

  Next

    

  sh2.Range("A4").Resize(UBound(b, 1), UBound(b, 2)).Value = b

End Sub

---

Archivo: