Excel Forum - Porady, Pomoc,  Excel Help, Excel FAQ Strona Główna
 FAQ  RegulaminRegulamin  Szukaj   Użytkownicy   Grupy   Rejestracja   Profil   Twoje wiadomości   Zaloguj 


Poprzedni temat «» Następny temat
ID tematu: 66171 Skopiuj do schowka [VBA] Przesłanki do nieużywania Application.Transpose
Autor Wiadomość
Artik 



Wersja: Win Office 365
Pomógł: 2940 razy
Posty: 9733
Wysłany: 28-09-2019, 14:19   [VBA] Przesłanki do nieużywania Application.Transpose

Jak wielu kodersów wie do wersji 2007(2010) był problem w VBA z użyciem funkcji TRANSPONUJ. Miała ona swoje ograniczenia do 65536 wierszy. Powyżej tej wartości się wykrzaczało. Od wersji 2010(2013) problem jakby został zlikwidowany.
Otóż okazuje się, że nie całkiem. Mało tego. Powiedziałbym, że raczej się nasilił!
Okazuje się, że chcąc transponować jednowymiarowe tablice mające więcej niż 65536 elementów, po zastosowaniu w VBA funkcji TRANSPONUJ otrzymujemy, owszem tablicę dwuwymiarową (pomijając szczególne przypadki), ale obciętą o wielokrotność 65536. I to bez komunikowania o błędzie!!!
Mówiąc po ludzku. Mamy tablicę v(1 To 65538), czyli o dwa elementy większą od magicznej granicy. Transponujemy ją funkcją arkuszową i otrzymujemy... v(1 To 2, 1 To 1). Podobnie z większymi tablicami. Przed: v(1 To 65536 * 2 + 2), a po transpozycji: v(1 To 2, 1 To 1).

I jak? Zadowoleni z takiego działania? :devil

Czując pismo nosem już od dawna (jeszcze przed zlotem w Białce Tatrzańskiej) zacząłem stosować inne rozwiązanie, z użyciem obiektu ListBox. Alternatywą jest też stosowanie własnej funkcji opartej na dwóch pętlach transponujących dane z tablicy źródłowej.

Zapraszam do testów.
Kod:
Sub Test()
    Dim v           As Variant
    Dim i           As Long
    Dim k           As Long

    '---- I ----
    ReDim v(1 To 65536)

    For i = 1 To 65536
        v(i) = i
    Next i

    MsgBox "Test1" & String(2, vbLf) & Info(v), vbInformation, "Przed transpozycją"
    v = Application.Transpose(v)
    MsgBox "Test1" & String(2, vbLf) & Info(v, 2), vbInformation, "Po transpozycji"


    '---- II ----
    ReDim v(1 To 65538)

    For i = 1 To 65538
        v(i) = i
    Next i

    MsgBox "Test2" & String(2, vbLf) & Info(v), vbInformation, "Przed transpozycją"
    v = Application.Transpose(v)
    MsgBox "Test2" & String(2, vbLf) & Info(v, 2), vbExclamation, "Po transpozycji"


    '---- III ----
    ReDim v(1 To 65536 * 2)

    For i = 1 To 65536 * 2
        v(i) = i
    Next i

    MsgBox "Test3" & String(2, vbLf) & Info(v), vbInformation, "Przed transpozycją"
    v = Application.Transpose(v)
    MsgBox "Test3" & String(2, vbLf) & Info(v, 2), vbExclamation, "Po transpozycji"


    '---- IV ----
    ReDim v(1 To 65536 * 2 + 2)

    For i = 1 To 65536 * 2 + 2
        v(i) = i
    Next i

    MsgBox "Test4" & String(2, vbLf) & Info(v), vbInformation, "Przed transpozycją"
    v = Application.Transpose(v)
    MsgBox "Test4" & String(2, vbLf) & Info(v, 2), vbExclamation, "Po transpozycji"


    '---- V ----
    ReDim v(1 To 65536 * 2 + 2, 1 To 3)

    For k = 1 To 3
        For i = 1 To 65536 * 2 + 2
            v(i, k) = i * k
        Next i
    Next k

    MsgBox "Test5" & String(2, vbLf) & Info(v, 2), vbInformation, "Przed transpozycją"
    v = Application.Transpose(v)
    MsgBox "Test5" & String(2, vbLf) & Info(v, 2), vbExclamation, "Po transpozycji"


    '---- VI ----
    ReDim v(1 To 65536 * 2 + 2, 1 To 3)

    For k = 1 To 3
        For i = 1 To 65536 * 2 + 2
            v(i, k) = i * k
        Next i
    Next k

    MsgBox "Test6" & String(2, vbLf) & Info(v, 2), vbInformation, "Przed transpozycją"
    v = TransposeDim(v)
    MsgBox "Test6" & String(2, vbLf) & Info(v, 2), vbInformation, "Po transpozycji"

End Sub



Function Info(v As Variant, Optional lDim As Long = 1) As String
    Dim lDim1       As Long
    Dim lDim2       As Long

    lDim1 = UBound(v)

    If lDim = 2 Then
        lDim2 = -2
        On Error Resume Next
        lDim2 = UBound(v, 2)
        On Error GoTo 0
    End If

    Select Case lDim
        Case 1
            Info = "Pierwszy wymiar: " & vbLf & _
                   LBound(v) & " do " & UBound(v)
        Case 2
            If lDim2 = -2 Then
                Info = "Pierwszy wymiar: " & vbLf & _
                       LBound(v) & " do " & UBound(v) & vbLf & _
                       "Drugi wymiar: " & vbLf & _
                       "BRAK!"

            Else
                Info = "Pierwszy wymiar: " & vbLf & _
                       LBound(v) & " do " & UBound(v) & vbLf & _
                       "Drugi wymiar: " & vbLf & _
                       LBound(v, 2) & " do " & UBound(v, 2)
            End If
    End Select
End Function


Function TransposeDim(vData)
    Dim LBound2     As Long
    'UWAGA funkcja zawsze zwraca tablicę o dolnej granicy = 0
    'tworzony jest w locie obiekt MSForms.Listbox

    LBound2 = -1

    If IsArray(vData) Then

        On Error Resume Next
        LBound2 = UBound(vData, 2)
        On Error GoTo 0

        With CreateObject("New:{8BD21D20-EC42-11CE-9E0D-00AA006002F3}")
            .Column = vData

            If LBound2 = -1 Then
                TransposeDim = .Column
            Else
                TransposeDim = .List
            End If
        End With

    End If
End Function

Artik
_________________
Persistence is a virtue in the world of programming.
ID posta: 374787 Skopiuj do schowka
 
 
apollo
ExcelSpec


Pomógł: 1295 razy
Posty: 4483
Wysłany: 28-09-2019, 23:54   

Obcięcie to nic wielkiego. U mnie (XP Home, Excel 2010) nie ma wyniku, jest tylko błąd.

W Test2, Test3, Test4, Test5 jest błąd "Type mismatch" w linii
Kod:

v = Application.Transpose(v)


2 For są szybsze od ListBox. U mnie For jest szybsza od ListBox 6 razy.
ID posta: 374802 Skopiuj do schowka
 
 
Artik 



Wersja: Win Office 365
Pomógł: 2940 razy
Posty: 9733
Wysłany: 29-09-2019, 00:31   

apollo napisał/a:
Obcięcie to nic wielkiego.
Nic wielkiego?! :shock:
Właśnie w tym problem. Bez jakichkolwiek oznak obcina mi dane. I przetwarzam je sobie (być może) nieświadomy.
To lepsze jest już wysypanie się makra. Przynajmniej wiadomo, że coś jest nie halo.

apollo napisał/a:
U mnie (XP Home, Excel 2010) nie ma wyniku, jest tylko błąd.
Trochę zbaboliłem. Powinno być
Cytat:
Od wersji 2013 problem jakby został zlikwidowany.


apollo napisał/a:
2 For są szybsze od ListBox. U mnie For jest szybsza od ListBox 6 razy.

Jakaś prosta funkcja z dwoma For...Next to faktycznie parę linijek.
Ale godziwie napisana funkcja, to już trochę więcej :devil
Kod:
Function ArrayTranspose(InputArray)
    'This function returns the transpose of the input array or range; it is designed
    'to avoid the limitation on the number of array elements and type of array that
    'the worksheet TRANSPOSE Function has.
    'http://www.excelforum.com/excel-programming/568747-solved-array-size-limit-when-using-worksheetfunction-transpose.html

    'Declare the variables
    Dim outputArrayTranspose As Variant, arr As Variant, p As Integer
    Dim i As Long, j As Long
    Dim Z           As Long
    Dim Msg         As String

    'Check to confirm that the input array
    'is an array or multicell range
    If IsArray(InputArray) Then

        'If so, convert an input range to a
        'true array
        arr = InputArray

        'Load the number of dimensions of
        'the input array to a variable
        On Error Resume Next

        'Loop until an error occurs
        i = 1
        Do
            Z = UBound(arr, i)
            i = i + 1
        Loop While Err = 0

        'Reset the error value for use with other procedures
        Err = 0

        'Return the number of dimensions
        p = i - 2
    End If

    If Not IsArray(InputArray) Or p > 2 Then
        Msg = "#ERROR! The function accepts only multi-cell ranges and 1D or 2D arrays."
        If TypeOf Application.Caller Is Range Then
            ArrayTranspose = Msg
        Else
            MsgBox Msg, 16
        End If
        Exit Function
    End If

    'Load the output array from a one-
    'dimensional input array
    If p = 1 Then

        Select Case TypeName(arr)
            Case "Object()"
                ReDim outputArrayTranspose(LBound(arr) To UBound(arr), _
                                           LBound(arr) To LBound(arr)) As Object
                For i = LBound(outputArrayTranspose) To _
                    UBound(outputArrayTranspose)
                    Set outputArrayTranspose(i, _
                                             LBound(outputArrayTranspose)) = arr(i)
                Next
            Case "Boolean()"
                ReDim outputArrayTranspose(LBound(arr) To UBound(arr), _
                                           LBound(arr) To LBound(arr)) As Boolean
            Case "Byte()"
                ReDim outputArrayTranspose(LBound(arr) To UBound(arr), _
                                           LBound(arr) To LBound(arr)) As Byte
            Case "Currency()"
                ReDim outputArrayTranspose(LBound(arr) To UBound(arr), _
                                           LBound(arr) To LBound(arr)) As Currency
            Case "Date()"
                ReDim outputArrayTranspose(LBound(arr) To UBound(arr), _
                                           LBound(arr) To LBound(arr)) As Date
            Case "Double()"
                ReDim outputArrayTranspose(LBound(arr) To UBound(arr), _
                                           LBound(arr) To LBound(arr)) As Double
            Case "Integer()"
                ReDim outputArrayTranspose(LBound(arr) To UBound(arr), _
                                           LBound(arr) To LBound(arr)) As Integer
            Case "Long()"
                ReDim outputArrayTranspose(LBound(arr) To UBound(arr), _
                                           LBound(arr) To LBound(arr)) As Long
            Case "Single()"
                ReDim outputArrayTranspose(LBound(arr) To UBound(arr), _
                                           LBound(arr) To LBound(arr)) As Single
            Case "String()"
                ReDim outputArrayTranspose(LBound(arr, 2) To _
                                           UBound(arr, 2), LBound(arr, 1) To UBound(arr, 1)) As String
            Case "Variant()"
                ReDim outputArrayTranspose(LBound(arr) To UBound(arr), _
                                           LBound(arr) To LBound(arr)) As Variant
            Case Else
                Msg = "#ERROR! Only built-in types of arrays are supported."
                If TypeOf Application.Caller Is Range Then
                    ArrayTranspose = Msg
                Else
                    MsgBox Msg, 16
                End If
                Exit Function
        End Select

        If TypeName(arr) <> "Object()" Then
            For i = LBound(outputArrayTranspose) To _
                UBound(outputArrayTranspose)
                outputArrayTranspose(i, LBound(outputArrayTranspose)) = arr(i)
            Next
        End If

        'Or load the output array from a two-
        'dimensional input array or range
    ElseIf p = 2 Then
        Select Case TypeName(arr)
            Case "Object()"
                ReDim outputArrayTranspose(LBound(arr, 2) To _
                                           UBound(arr, 2), _
                                           LBound(arr) To UBound(arr)) As Object
                For i = LBound(outputArrayTranspose) To _
                    UBound(outputArrayTranspose)
                    For j = LBound(outputArrayTranspose, 2) To _
                        UBound(outputArrayTranspose, 2)
                        Set outputArrayTranspose(i, j) = arr(j, i)
                    Next
                Next
            Case "Boolean()"
                ReDim outputArrayTranspose(LBound(arr, 2) To _
                                           UBound(arr, 2), _
                                           LBound(arr) To UBound(arr)) As Boolean
            Case "Byte()"
                ReDim outputArrayTranspose(LBound(arr, 2) To _
                                           UBound(arr, 2), _
                                           LBound(arr) To UBound(arr)) As Byte
            Case "Currency()"
                ReDim outputArrayTranspose(LBound(arr, 2) To _
                                           UBound(arr, 2), _
                                           LBound(arr) To UBound(arr)) As Currency
            Case "Date()"
                ReDim outputArrayTranspose(LBound(arr, 2) To _
                                           UBound(arr, 2), _
                                           LBound(arr) To UBound(arr)) As Date
            Case "Double()"
                ReDim outputArrayTranspose(LBound(arr, 2) To _
                                           UBound(arr, 2), _
                                           LBound(arr) To UBound(arr)) As Double
            Case "Integer()"
                ReDim outputArrayTranspose(LBound(arr, 2) To _
                                           UBound(arr, 2), _
                                           LBound(arr) To UBound(arr)) As Integer
            Case "Long()"
                ReDim outputArrayTranspose(LBound(arr, 2) To _
                                           UBound(arr, 2), _
                                           LBound(arr) To UBound(arr)) As Long
            Case "Single()"
                ReDim outputArrayTranspose(LBound(arr, 2) To _
                                           UBound(arr, 2), _
                                           LBound(arr) To UBound(arr)) As Single
            Case "String()"
                ReDim outputArrayTranspose(LBound(arr, 2) To _
                                           UBound(arr, 2), _
                                           LBound(arr) To UBound(arr)) As String
            Case "Variant()"
                ReDim outputArrayTranspose(LBound(arr, 2) To _
                                           UBound(arr, 2), _
                                           LBound(arr) To UBound(arr)) As Variant
            Case Else
                Msg = "#ERROR! Only built-in types of arrays are supported."
                If TypeOf Application.Caller Is Range Then
                    ArrayTranspose = Msg
                Else
                    MsgBox Msg, 16
                End If
                Exit Function
        End Select

        If TypeName(arr) <> "Object()" Then
            For i = LBound(outputArrayTranspose) To _
                UBound(outputArrayTranspose)
                For j = LBound(outputArrayTranspose, 2) To _
                    UBound(outputArrayTranspose, 2)
                    outputArrayTranspose(i, j) = arr(j, i)
                Next
            Next
        End If

    End If

    'Return the transposed array
    ArrayTranspose = outputArrayTranspose
End Function
Jak będę walczył o milisekundy, to pewnie użyję powyższej czy wręcz dedykowanej do chwilowych potrzeb. Na co dzień wolę jednak rozwiązanie z ListBox-em. Po prostu krótsze.

Artik
_________________
Persistence is a virtue in the world of programming.
ID posta: 374803 Skopiuj do schowka
 
 
Wyświetl posty z ostatnich:   
Odpowiedz do tematu
Nie możesz pisać nowych tematów
Nie możesz odpowiadać w tematach
Nie możesz zmieniać swoich postów
Nie możesz usuwać swoich postów
Nie możesz głosować w ankietach
Nie możesz załączać plików na tym forum
Możesz ściągać załączniki na tym forum
Dodaj temat do Ulubionych
Wersja do druku

Skocz do:  

Powered by phpBB modified by Przemo © 2003 phpBB Group
Theme xandgreen created by spleen& Programosy modified v0.3 by warna
Opieka techniczna www.marketingNET.pl

Archiwum

Strona używa plików cookies.

Kliknij tutaj, żeby dowiedzieć się jaki jest cel używania cookies oraz jak zmienić ustawienia cookie w przeglądarce.
Korzystając ze strony użytkownik wyraża zgodę na używanie plików cookies, zgodnie z bieżącymi ustawieniami przeglądarki.
Sprawdź, w jaki sposób przetwarzamy dane osobowe