Ubound supprimer mes formules matricielles

Le 05/05/2021 à 11:01

Bonjour,

voici le code suivant sur mon fichier.

Sub recherche()

Dim I As Long, j As Integer
Dim r As Variant
Dim d1 As Long
Dim Tablo(), Tabhorsmoso(), Tabmoso(), Tabreg()

'déprotéger la feuille
Sheets("suivi").Unprotect Password:="terra"

Tabhorsmoso = Range("horsmoso").Value
Tabmoso = Range("moso")
Tabreg = Range("reg")

'Application.Calculation = xlManual

d1 = Sheets("suivi").Range("A" & Rows.Count).End(xlUp).Row
Tablo = Range("A2:AM" & d1).Value
For I = 1 To d1 - 1
    If Tablo(I, 13) = "inopiné" Then
        For j = 1 To UBound(Tabmoso)
            If Tabmoso(j, 1) = Tablo(I, 14) Then Tablo(I, 15) = Tabmoso(j, 2)
            If Tabmoso(j, 1) = Tablo(I, 14) Then Tablo(I, 16) = Tabmoso(j, 3)
            If Tabmoso(j, 1) = Tablo(I, 14) Then Tablo(I, 17) = Tabmoso(j, 4)
            If Tabmoso(j, 1) = Tablo(I, 14) Then Tablo(I, 19) = Tabmoso(j, 5): Exit For
        Next j

        'Sheets("suivi").Range("C" & i).Value = Application.VLookup(Sheets("suivi").Range("B" & i), Sheets("frs_moso").Range("A1:B4"), 2, False)
    ElseIf Tablo(I, 13) = "régulier" Then
        For j = 1 To UBound(Tabreg)
            If Tabreg(j, 1) = Tablo(I, 14) Then Tablo(I, 15) = Tabreg(j, 2)
            If Tabreg(j, 1) = Tablo(I, 14) Then Tablo(I, 16) = Tabreg(j, 3)
            If Tabreg(j, 1) = Tablo(I, 14) Then Tablo(I, 17) = Tabreg(j, 4)
            If Tabreg(j, 1) = Tablo(I, 14) Then Tablo(I, 19) = Tabreg(j, 5): Exit For
        Next j
        'Sheets("suivi").Range("C" & i).Value = Application.VLookup(Sheets("suivi").Range("B" & i), Sheets("frs_reg").Range("A1:B4"), 2, False)
    ElseIf Tablo(I, 13) = "hors_moso" Then
        For j = 1 To UBound(Tabhorsmoso)
            If Tabhorsmoso(j, 1) = Tablo(I, 14) Then Tablo(I, 15) = Tabhorsmoso(j, 2)
            If Tabhorsmoso(j, 1) = Tablo(I, 14) Then Tablo(I, 16) = Tabhorsmoso(j, 3)
            If Tabhorsmoso(j, 1) = Tablo(I, 14) Then Tablo(I, 17) = Tabhorsmoso(j, 4)
            If Tabhorsmoso(j, 1) = Tablo(I, 14) Then Tablo(I, 19) = Tabhorsmoso(j, 5): Exit For
        Next j
        'Sheets("suivi").Range("C" & i).Value = Application.VLookup(Sheets("suivi").Range("B" & i), Sheets("frs_hors_moso").Range("A1:B4"), 2, False)
    ElseIf Tablo(I, 13) = "" Then
    Tablo(I, 15) = ""
    Tablo(I, 16) = ""
    Tablo(I, 17) = ""
    Tablo(I, 19) = ""

    End If

Next I

'Range("A2").Resize(UBound(Tablo, 1), UBound(Tablo, 2)) = Tablo

Application.Calculation = xlAutomatic

'vérouiller la feuille suivi
Sheets("suivi").Protect Password:="terra"
Sheets("suivi").Protect contents:=True, AllowFormattingColumns:=True, AllowInsertingRows:=True, AllowUsingPivotTables:=True, AllowInsertingHyperlinks:=True, AllowFormattingCells:=True, AllowFiltering:=True, Password:="terra"

End Sub

Lorsque mon code s'effectue, mes formules matricielles se suppriment. J'ai trouvé la ligne qui fait ça.

c'est cette ligne là :

Range("A2").Resize(UBound(Tablo, 1), UBound(Tablo, 2)) = Tablo

Par quoi puis je la remplacer ?

Merci d'avance.

Il m'est complique de transmettre le fichier car il y a des informations confidentielles dessus.

Le 05/05/2021 à 11:03

si je la supprime, mon code ne fonctionne plus .... que faire ?

Le 05/05/2021 à 12:16

Bonjour,

Quelles sont les colonnes avec formules matricielles ?

le tableau Tablo pourrait (peut-être) être réduit et ainsi ne plus "écraser" ces formules....

A+

Le 05/05/2021 à 22:57

Bonjour à tous,

Voici un essai en passant par 2 fonctions pour prendre et restituer les formules matricielles :

Sub recherche()

Dim I As Long, j As Integer
Dim r As Variant
Dim d1 As Long
Dim Tablo(), Tabhorsmoso(), Tabmoso(), Tabreg()

'déprotéger la feuille
Sheets("suivi").Unprotect Password:="terra"

Tabhorsmoso = Range("horsmoso").Value
Tabmoso = Range("moso")
Tabreg = Range("reg")

'Application.Calculation = xlManual

d1 = Sheets("suivi").Range("A" & Rows.Count).End(xlUp).Row
Tablo = GetArrayWithFormulaArray(Range("A2:AM" & d1)) '<<<<<<<< CHANGEMENT : ALIMENTATION
For I = 1 To d1 - 1
    If Tablo(I, 13) = "inopiné" Then
        For j = 1 To UBound(Tabmoso)
            If Tabmoso(j, 1) = Tablo(I, 14) Then Tablo(I, 15) = Tabmoso(j, 2)
            If Tabmoso(j, 1) = Tablo(I, 14) Then Tablo(I, 16) = Tabmoso(j, 3)
            If Tabmoso(j, 1) = Tablo(I, 14) Then Tablo(I, 17) = Tabmoso(j, 4)
            If Tabmoso(j, 1) = Tablo(I, 14) Then Tablo(I, 19) = Tabmoso(j, 5): Exit For
        Next j

        'Sheets("suivi").Range("C" & i).Value = Application.VLookup(Sheets("suivi").Range("B" & i), Sheets("frs_moso").Range("A1:B4"), 2, False)
    ElseIf Tablo(I, 13) = "régulier" Then
        For j = 1 To UBound(Tabreg)
            If Tabreg(j, 1) = Tablo(I, 14) Then Tablo(I, 15) = Tabreg(j, 2)
            If Tabreg(j, 1) = Tablo(I, 14) Then Tablo(I, 16) = Tabreg(j, 3)
            If Tabreg(j, 1) = Tablo(I, 14) Then Tablo(I, 17) = Tabreg(j, 4)
            If Tabreg(j, 1) = Tablo(I, 14) Then Tablo(I, 19) = Tabreg(j, 5): Exit For
        Next j
        'Sheets("suivi").Range("C" & i).Value = Application.VLookup(Sheets("suivi").Range("B" & i), Sheets("frs_reg").Range("A1:B4"), 2, False)
    ElseIf Tablo(I, 13) = "hors_moso" Then
        For j = 1 To UBound(Tabhorsmoso)
            If Tabhorsmoso(j, 1) = Tablo(I, 14) Then Tablo(I, 15) = Tabhorsmoso(j, 2)
            If Tabhorsmoso(j, 1) = Tablo(I, 14) Then Tablo(I, 16) = Tabhorsmoso(j, 3)
            If Tabhorsmoso(j, 1) = Tablo(I, 14) Then Tablo(I, 17) = Tabhorsmoso(j, 4)
            If Tabhorsmoso(j, 1) = Tablo(I, 14) Then Tablo(I, 19) = Tabhorsmoso(j, 5): Exit For
        Next j
        'Sheets("suivi").Range("C" & i).Value = Application.VLookup(Sheets("suivi").Range("B" & i), Sheets("frs_hors_moso").Range("A1:B4"), 2, False)
    ElseIf Tablo(I, 13) = "" Then
    Tablo(I, 15) = ""
    Tablo(I, 16) = ""
    Tablo(I, 17) = ""
    Tablo(I, 19) = ""

    End If

Next I

PasteArrayWithFormulaArray Tablo, Range("A2") '<<<<<< CHANGEMENT : COLLAGE

Application.Calculation = xlAutomatic

'vérouiller la feuille suivi
Sheets("suivi").Protect Password:="terra"
Sheets("suivi").Protect contents:=True, AllowFormattingColumns:=True, AllowInsertingRows:=True, AllowUsingPivotTables:=True, AllowInsertingHyperlinks:=True, AllowFormattingCells:=True, AllowFiltering:=True, Password:="terra"

End Sub

function GetArrayWithFormulaArray(r as Range)
redim t(1 to r.rows.count, 1 to r.columns.count)
for i = 1 to r.rows.count
    for k = 1 to r.columns.count
        t(i, k) = r(i, k).formulaarray
    next k
next i
GetArrayWithFormulaArray = t
end function

function PasteArrayWithFormulaArray(t, topleftcelldest as range)
application.calculation = xlcalculationmanual
with topleftcelldest.resize(ubound(t), ubound(t, 2))
    for i = 1 to .rows.count
        for k = 1 to .columns.count
            if .cells(i, k).hasarray then .cells(i, k).formulaarray = t(i, k) else .cells(i, k).formula = t(i, k)
        next k
    next i
end with
application.calculation = xlcalculationautomatic
end function

Si vous dépassiez 4 cas (moso, régulier, hors moso, ""), il faudrait peut-être penser à factoriser le code...

Cdlt,

Le 12/05/2021 à 14:20

Bonjour,

même en réduisant le tableau, mes formules matricielles s'enlèvent encore..

je vais essayer ta solution @3GB

merci

Le 13/05/2021 à 16:25

Sans classeur pour investiguer , pas d'autres solutions à proposer.

Bonne suite

Rechercher des sujets similaires à "ubound supprimer mes formules matricielles"