Saltar al contenido

Matrices bidimensionales de VBA Excel

Hemos estado indagado por el mundo on line y así de este modo brindarte la solución a tu problema, si continúas con dudas déjanos tu pregunta y contestaremos porque estamos para ayudarte.

Solución:

De hecho, no usaría ningún REDIM, ni un bucle para transferir datos de una hoja a otra. array:

dim arOne()
arOne = range("A2:F1000")

o incluso

arOne = range("A2").CurrentRegion

y eso es todo, tu array se llena mucho más rápido que con un bucle, sin redim.

Necesitas ReDim:

m = 5
n = 8
Dim my_array()
ReDim my_array(1 To m, 1 To n)
For i = 1 To m
  For j = 1 To n
    my_array(i, j) = i * j
  Next
Next

For i = 1 To m
  For j = 1 To n
    Cells(i, j) = my_array(i, j)
  Next
Next

Como han señalado otros, su problema real se resolvería mejor con rangos. Podrías probar algo como esto:

Dim r1 As Range
Dim r2 As Range
Dim ws1 As Worksheet
Dim ws2 As Worksheet

Set ws1 = Worksheets("Sheet1")
Set ws2 = Worksheets("Sheet2")
totalRow = ws1.Range("A1").End(xlDown).Row
totalCol = ws1.Range("A1").End(xlToRight).Column

Set r1 = ws1.Range(ws1.Cells(1, 1), ws1.Cells(totalRow, totalCol))
Set r2 = ws2.Range(ws2.Cells(1, 1), ws2.Cells(totalRow, totalCol))
r2.Value = r1.Value

Aquí está Una función genérica de matriz a rango de VBA que escribe un array a la hoja de un solo ‘golpe’ a la hoja. Este es mucho más rápido que escribir los datos en la hoja una celda a la vez en bucles para las filas y columnas … Sin embargo, hay que hacer algunas tareas de limpieza, ya que debe especificar el tamaño del rango objetivo correctamente.

Esta ‘limpieza’ parece mucho trabajo y probablemente sea bastante lenta: pero este es el código de ‘última milla’ para escribir en la hoja, y todo es más rápido que escribir en la hoja de trabajo. O al menos, mucho más rápido que es efectivamente instantáneo, en comparación con una lectura o escritura en la hoja de trabajo, incluso en VBA, y debe hacer todo lo que pueda en el código antes de llegar a la hoja.

Un componente importante de esto es la captura de errores que solía ver aparecer en todas partes. Odio la codificación repetitiva: lo he codificado todo aquí y, con suerte, nunca tendrás que volver a escribirlo.

Una función de VBA ‘Array to Range’

Public Sub ArrayToRange(rngTarget As Excel.Range, InputArray As Variant)
' Write an array to an Excel range in a single 'hit' to the sheet
' InputArray must be a 2-Dimensional structure of the form Variant(Rows, Columns)

' The target range is resized automatically to the dimensions of the array, with
' the top left cell used as the start point.

' This subroutine saves repetitive coding for a common VBA and Excel task.

' If you think you won't need the code that works around common errors (long strings
' and objects in the array, etc) then feel free to comment them out.

On Error Resume Next

'
' Author: Nigel Heffernan
' HTTP://Excellerando.blogspot.com
'
' This code is in te public domain: take care to mark it clearly, and segregate
' it from proprietary code if you intend to assert intellectual property rights
' or impose commercial confidentiality restrictions on that proprietary code

Dim rngOutput As Excel.Range

Dim iRowCount   As Long
Dim iColCount   As Long
Dim iRow        As Long
Dim iCol        As Long
Dim arrTemp     As Variant
Dim iDimensions As Integer

Dim iRowOffset  As Long
Dim iColOffset  As Long
Dim iStart      As Long


Application.EnableEvents = False
If rngTarget.Cells.Count > 1 Then
    rngTarget.ClearContents
End If
Application.EnableEvents = True

If IsEmpty(InputArray) Then
    Exit Sub
End If


If TypeName(InputArray) = "Range" Then
    InputArray = InputArray.Value
End If

' Is it actually an array? IsArray is sadly broken so...
If Not InStr(TypeName(InputArray), "(") Then
    rngTarget.Cells(1, 1).Value2 = InputArray
    Exit Sub
End If


iDimensions = ArrayDimensions(InputArray)

If iDimensions < 1 Then

    rngTarget.Value = CStr(InputArray)

ElseIf iDimensions = 1 Then

    iRowCount = UBound(InputArray) - LBound(InputArray)
    iStart = LBound(InputArray)
    iColCount = 1

    If iRowCount > (655354 - rngTarget.Row) Then
        iRowCount = 655354 + iStart - rngTarget.Row
        ReDim Preserve InputArray(iStart To iRowCount)
    End If

    iRowCount = UBound(InputArray) - LBound(InputArray)
    iColCount = 1

    ' It's a vector. Yes, I asked for a 2-Dimensional array. But I'm feeling generous.
    ' By convention, a vector is presented in Excel as an arry of 1 to n rows and 1 column.
    ReDim arrTemp(LBound(InputArray, 1) To UBound(InputArray, 1), 1 To 1)
    For iRow = LBound(InputArray, 1) To UBound(InputArray, 1)
        arrTemp(iRow, 1) = InputArray(iRow)
    Next

    With rngTarget.Worksheet
        Set rngOutput = .Range(rngTarget.Cells(1, 1), rngTarget.Cells(iRowCount + 1, iColCount))
        rngOutput.Value2 = arrTemp
        Set rngTarget = rngOutput
    End With

    Erase arrTemp

ElseIf iDimensions = 2 Then

    iRowCount = UBound(InputArray, 1) - LBound(InputArray, 1)
    iColCount = UBound(InputArray, 2) - LBound(InputArray, 2)

    iStart = LBound(InputArray, 1)

    If iRowCount > (65534 - rngTarget.Row) Then
        iRowCount = 65534 - rngTarget.Row
        InputArray = ArrayTranspose(InputArray)
        ReDim Preserve InputArray(LBound(InputArray, 1) To UBound(InputArray, 1), iStart To iRowCount)
        InputArray = ArrayTranspose(InputArray)
    End If


    iStart = LBound(InputArray, 2)
    If iColCount > (254 - rngTarget.Column) Then
        ReDim Preserve InputArray(LBound(InputArray, 1) To UBound(InputArray, 1), iStart To iColCount)
    End If



    With rngTarget.Worksheet

        Set rngOutput = .Range(rngTarget.Cells(1, 1), rngTarget.Cells(iRowCount + 1, iColCount + 1))

        Err.Clear
        Application.EnableEvents = False
        rngOutput.Value2 = InputArray
        Application.EnableEvents = True

        If Err.Number <> 0 Then
            For iRow = LBound(InputArray, 1) To UBound(InputArray, 1)
                For iCol = LBound(InputArray, 2) To UBound(InputArray, 2)
                    If IsNumeric(InputArray(iRow, iCol)) Then
                        ' no action
                    Else
                        InputArray(iRow, iCol) = "" & InputArray(iRow, iCol)
                        InputArray(iRow, iCol) = Trim(InputArray(iRow, iCol))
                    End If
                Next iCol
            Next iRow
            Err.Clear
            rngOutput.Formula = InputArray
        End If 'err<>0

        If Err <> 0 Then
            For iRow = LBound(InputArray, 1) To UBound(InputArray, 1)
                For iCol = LBound(InputArray, 2) To UBound(InputArray, 2)
                    If IsNumeric(InputArray(iRow, iCol)) Then
                        ' no action
                    Else
                        If Left(InputArray(iRow, iCol), 1) = "=" Then
                            InputArray(iRow, iCol) = "'" & InputArray(iRow, iCol)
                        End If
                        If Left(InputArray(iRow, iCol), 1) = "+" Then
                            InputArray(iRow, iCol) = "'" & InputArray(iRow, iCol)
                        End If
                        If Left(InputArray(iRow, iCol), 1) = "*" Then
                            InputArray(iRow, iCol) = "'" & InputArray(iRow, iCol)
                        End If
                    End If
                Next iCol
            Next iRow
            Err.Clear
            rngOutput.Value2 = InputArray
        End If 'err<>0

        If Err <> 0 Then
            For iRow = LBound(InputArray, 1) To UBound(InputArray, 1)
                For iCol = LBound(InputArray, 2) To UBound(InputArray, 2)

                    If IsObject(InputArray(iRow, iCol)) Then
                        InputArray(iRow, iCol) = "[OBJECT] " & TypeName(InputArray(iRow, iCol))
                    ElseIf IsArray(InputArray(iRow, iCol)) Then
                        InputArray(iRow, iCol) = Split(InputArray(iRow, iCol), ",")
                    ElseIf IsNumeric(InputArray(iRow, iCol)) Then
                        ' no action
                    Else
                        InputArray(iRow, iCol) = "" & InputArray(iRow, iCol)
                        If Len(InputArray(iRow, iCol)) > 255 Then
                            ' Block-write operations fail on strings exceeding 255 chars. You *have*
                            ' to go back and check, and write this masterpiece one cell at a time...
                            InputArray(iRow, iCol) = Left(Trim(InputArray(iRow, iCol)), 255)
                        End If
                    End If
                Next iCol
            Next iRow
            Err.Clear
            rngOutput.Text = InputArray
        End If 'err<>0

        If Err <> 0 Then
            Application.ScreenUpdating = False
            Application.Calculation = xlCalculationManual
            iRowOffset = LBound(InputArray, 1) - 1
            iColOffset = LBound(InputArray, 2) - 1
            For iRow = 1 To iRowCount
                If iRow Mod 100 = 0 Then
                    Application.StatusBar = "Filling range... " & CInt(100# * iRow / iRowCount) & "%"
                End If
                For iCol = 1 To iColCount
                    rngOutput.Cells(iRow, iCol) = InputArray(iRow + iRowOffset, iCol + iColOffset)
                Next iCol
            Next iRow
            Application.StatusBar = False
            Application.ScreenUpdating = True


        End If 'err<>0


        Set rngTarget = rngOutput   ' resizes the range This is useful, *most* of the time

    End With

End If

End Sub

Necesitará la fuente de ArrayDimensions:

Esta declaración de API es necesaria en el encabezado del módulo:

Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" _
                   (Destination As Any, _
                    Source As Any, _
                    ByVal Length As Long)

… Y aquí está la función en sí:

Private Function ArrayDimensions(arr As Variant) As Integer
  '-----------------------------------------------------------------
  ' will return:
  ' -1 if not an array
  ' 0  if an un-dimmed array
  ' 1  or more indicating the number of dimensions of a dimmed array
  '-----------------------------------------------------------------


  ' Retrieved from Chris Rae's VBA Code Archive - http://chrisrae.com/vba
  ' Code written by Chris Rae, 25/5/00

  ' Originally published by R. B. Smissaert.
  ' Additional credits to Bob Phillips, Rick Rothstein, and Thomas Eyde on VB2TheMax

  Dim ptr As Long
  Dim vType As Integer

  Const VT_BYREF = &H4000&

  'get the real VarType of the argument
  'this is similar to VarType(), but returns also the VT_BYREF bit
  CopyMemory vType, arr, 2

  'exit if not an array
  If (vType And vbArray) = 0 Then
    ArrayDimensions = -1
    Exit Function
  End If

  'get the address of the SAFEARRAY descriptor
  'this is stored in the second half of the
  'Variant parameter that has received the array
  CopyMemory ptr, ByVal VarPtr(arr) + 8, 4

  'see whether the routine was passed a Variant
  'that contains an array, rather than directly an array
  'in the former case ptr already points to the SA structure.
  'Thanks to Monte Hansen for this fix

  If (vType And VT_BYREF) Then
    ' ptr is a pointer to a pointer
    CopyMemory ptr, ByVal ptr, 4
  End If

  'get the address of the SAFEARRAY structure
  'this is stored in the descriptor

  'get the first word of the SAFEARRAY structure
  'which holds the number of dimensions
  '...but first check that saAddr is non-zero, otherwise
  'this routine bombs when the array is uninitialized

  If ptr Then
    CopyMemory ArrayDimensions, ByVal ptr, 2
  End If

End Function

Además: le aconsejaría que mantenga esa declaración en privado. Si debe convertirlo en un Sub público en otro módulo, inserte el Option Private Module declaración en el encabezado del módulo. Realmente no desea que sus usuarios llamen a ninguna función con operaciones CopyMemory y aritmética de punteros.

valoraciones y comentarios

¡Haz clic para puntuar esta entrada!
(Votos: 0 Promedio: 0)



Utiliza Nuestro Buscador

Deja una respuesta

Tu dirección de correo electrónico no será publicada. Los campos obligatorios están marcados con *