Jump to content

Antoni

Members
  • Posts

    11,090
  • Joined

  • Last visited

  • Days Won

    747

Posts posted by Antoni

  1. Sub FormatoNúmeros()
    Dim R As Range, Texto As String
    Application.ScreenUpdating = False
    ActiveSheet.Copy After:=ActiveSheet
    For x = 2 To Hoja1.Range("A" & Rows.Count).End(xlUp).Row
       For y = 7 To Hoja1.Cells(1, Columns.Count).End(xlToLeft).Column
          Texto = Trim(Hoja1.Cells(x, y))
          Set R = Sheets("Cuestionario Horizontal").Columns(y - 6).Find(Texto, , , xlWhole)
          If Not R Is Nothing Then If Not R = "" Then Cells(x, y) = R.Row - 1
       Next
    Next
    End Sub

     

  2. Sub crearHoja()
    Dim Hoja As String
    
    Hoja = "Benito" '<---------- Tu hoja nueva
    
    If ExisteHoja(Hoja) Then
       MsgBox "Ya existe la hoja " & Hoja, vbCritical
    Else
       Sheets.Add(After:=Sheets(Sheets.Count)).Name = Hoja
       MsgBox "Se ha creado la hoja " & Hoja, vbInformation
    End If
    End Sub
    
    Function ExisteHoja(Hoja As String) As Boolean
    For h = 1 To Sheets.Count
       If Sheets(h).Name = Hoja Then
          ExisteHoja = True
          Exit Function
       End If
    Next h
    End Function

     

  3. Abre el adjunto y pulsa la flecha azul.

    Esta es la macro.

    Sub OrdenarFiltro()
    Application.CopyObjectsWithCells = False '<-- Para no copiar las autoformas
    Application.ScreenUpdating = False
    With Hoja2
       .UsedRange.Clear
       Hoja1.UsedRange.SpecialCells(xlCellTypeVisible).Copy .Cells
       .UsedRange.Sort Key1:=.Columns("C"), Key2:=.Columns("B"), Header:=xlYes
       .Select
    End With
    Application.CopyObjectsWithCells = True
    End Sub

     

  4. Sub Desordenar()
    Application.ScreenUpdating = False
    Range("A:C").Copy Range("F:H")
    Columns("D").Clear
    x = Range("A" & Rows.Count).End(xlUp).Row
    filas = 2
    Do Until filas > x
       fila = Int(Rnd * x) + 1
       If fila > 1 Then
          If Range("D" & fila) = "" Then
             Range("D" & fila) = "x"
             Range("A" & fila).Resize(1, 3).Copy Range("F" & filas)
             filas = filas + 1
          End If
       End If
    Loop
    Range("F:I").Cut Range("A:D")
    End Sub

    Peo mejor usar la macro de Gerson.

  5. Por alguna razón, ciertos errores se escapan a On Error, así te funcionará.

    Sub pruebaImg(): On Error Resume Next
    
    Sheets("Full2").Select
    
    Sheets("Full1").Shapes("Imagen1").Copy
    If Err.Number = 0 Then
      Range("c1").Select
      ActiveSheet.Paste
    End If
    Err.Number = 0
    
    Sheets("Full1").Shapes("Imagen2").Copy
    If Err.Number = 0 Then
      Range("e1").Select
      ActiveSheet.Paste
    End If
    Err.Number = 0
    
    Sheets("Full1").Shapes("Imagen3").Copy
    If Err.Number = 0 Then
      Range("i1").Select
      ActiveSheet.Paste
    End If
    Err.Number = 0
    
    Sheets("Full1").Shapes("Imagen4").Copy
    If Err.Number = 0 Then
      Range("m1").Select
      ActiveSheet.Paste
    End If
    Err.Number = 0
    
    Sheets("Full1").Shapes("Imagen5").Copy
    If Err.Number = 0 Then
      Range("r1").Select
      ActiveSheet.Paste
    End If
    End Sub

     

  6. No es necesario recurrir a la columna en letras utilizando la propiedad Cells del objeto Range.

    Private Sub BtGrabar_Click()
    Dim celda As Range, x As Long, Incidencias As Range
    Application.ScreenUpdating = False
    If CBoxPeriodo.ListIndex = -1 Then Exit Sub
    With Sheets("PARQUE")
       Set celda = .Range("A1:AZ1").Find(CBoxPeriodo, , , xlWhole)
       Set Incidencias = .Range("A1:AZ1").Find("INCIDENCIA", , , xlPart)
       .Columns(celda.Column).ClearComments
       For x = 2 To .Cells(Rows.Count, Incidencias.Column).End(xlUp).Row
          If Not .Cells(x, Incidencias.Column).Value = "" Then
             .Cells(x, celda.Column).AddComment
             .Cells(x, celda.Column).Comment.Text Text:=.Cells(x, Incidencias.Column).Value
          End If
       Next
    End With
    Application.ScreenUpdating = True
    End Sub

     

  7. Sub Importar_Fichero()
    Dim Archivo As Variant
    Dim Examinar As Object
    '--
    ChDir ThisWorkbook.Path
    Set Examinar = Application.FileDialog(msoFileDialogFilePicker)
    With Examinar
       .AllowMultiSelect = True
       .Title = "Seleccionar archivos a consolidar"
       If .Show = -1 Then
           Sheets("Hoja1").Range("A2:AO" & Rows.Count).ClearContents
           For Each Archivo In .SelectedItems
             ConsolidarArchivo Archivo
           Next
           Sheets("Hoja1").Activate
           MsgBox "Carga completada"
       End If
    End With
    End Sub
    '---------------
    Private Sub ConsolidarArchivo(Archivo As Variant)
    Application.ScreenUpdating = False
    Application.StatusBar = Archivo
    With ThisWorkbook.Sheets("Hoja1")
       Fila = .Range("A" & Rows.Count).End(xlUp).Row + 1
       Workbooks.Open Archivo
       Range("A2:AO" & Range("A" & Rows.Count).End(xlUp).Row).Copy .Range("A" & Fila)
    End With
    Application.StatusBar = False
    ActiveWorkbook.Close
    End Sub

     

×
×
  • Create New...

Important Information

Privacy Policy