Schnell sehr viele Formeln ins Blatt schreiben

Hallo Wissende,
die Datei: https://www.herber.de/bbs/user/75334.xlsm
hat nachfolgenden Code, gestartet mit dem Button Blatt1.
ES folgen jetzt Hintergrundinformationen, prinzipiell nicht so wichtig. Die konkrete Frage ist dann das nächste Fettgedruckte.

Ein Anfrager in einem anderen Forum will für jede Zelle im Blatt2 als Ergebnis stehen haben wie oft der analoge Wert in der gleichen Zelle in Blatt1 in Blatt1 vorkommt. Dafür zeigte er diese Formel:
=WENN('Blatt1'!A10;ZÄHLENWENN('^Blatt1'!$A$1:$ALL$1000;'Blatt1'!A1);"")
Nach Nachfrage was er denn mit "Excel nippelt ab" meint kam raus daß er da wohl in kleineren Bereichen manuell die Formel reinkopiert hat, da die zeit gemessen/geschätzt hat und kam auf 250 min für die 1 Mio Zellen.
Excel- oder Vbalösung ist egal.
Ich habe dann verschiedene Varianten durchgetestet.
Also mit
Bereich.Formula=Formel
Das dauerte mir zu lang.
Dann probierte ich es so:
Bereich.Value="#" & Formel
Dann wollte ich dann einfach die "#" durch Ersetzen weglöschen, klappte auch nicht.
Es tat sich schlichtweg nix obwohl es angeppasster aufgezeichneter Code war.
Und ich habe noch mehr probiert ... :-(
Das war jetzt nur zur Erhellung des Hintergrundes, jetzt meine konkrete Frage.
Ich möchte in einem Bereich in Blatt2 in jeder Zelle stehen haben wie oft der Wert des gleichen Zellennamens in Blatt1 in dem Blatt1 vorkommt.
Excel- oder Vbalösung ist egal, gesucht ist die schnellste Methode/Code.

Danke ^ Gruß
Reinhard


Option Explicit
Sub Zaehlen()
Dim Ber(1 To 1000, 1 To 1000) As String, a As Integer, b As Integer
Dim T As Single, Formel As String
T = Timer
Formel = "=IF(Tabelle1!RC0,COUNTIF(Tabelle1!R1C1:R1000C1000,Tabelle1!RC),"""")"
ActiveWorkbook.Names.Add Name:="XXX", RefersToR1C1:=Formel
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Worksheets("Tabelle2").UsedRange.ClearContents
For a = 1 To 1000
For b = 1 To 1000
Ber(a, b) = "=XXX"
Next b
Next a
Worksheets("Tabelle2").Range("A1:ALL1000") = Ber
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
MsgBox Timer - T
End Sub

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Benutzer

HAllo
Bei sovielen Formeln kann Excel sich schonmal verschlucken.
Ich hab mal versucht anhand deiner Angaben eine Testtabelle mit Werten zu erstellen.
Versuch mal diesen Code:

Public Sub test()
    Dim arr
    Dim myDic As Object
    Dim out
    Dim L As Long
    Dim I As Integer
    Dim T As Double

    T = Timer
    Set myDic = CreateObject("Scripting.Dictionary")
    arr = Sheets("TAbelle1").Range("A1:ALL1000")

    For L = 1 To UBound(arr)
        For I = 1 To UBound(arr, 2)
            myDic(arr(L, I)) = myDic(arr(L, I)) + 1
        Next
    Next

    out = Sheets("TAbelle2").Range("A1:ALL1000")

    For L = 1 To UBound(out)
        For I = 1 To UBound(out, 2)
            out(L, I) = myDic(out(L, I))
        Next
    Next
    Sheets("TAbelle2").Range("A1:ALL1000") = out
    MsgBox Timer - T
End Sub

ransi

' ********************************************************************** ' Modul: Modul1 Typ: Allgemeines Modul ' ********************************************************************** Option Explicit Sub Zaehlen() Dim rng As Range Dim lngCol As Long, lngRow As Long Dim vntValues As Variant, vntRet() As Variant Dim t As Double t = Timer Set rng = Sheets("Tabelle1").Range("A1:ALL1000") vntValues = rng Redim vntRet(1 To UBound(vntValues, 1), 1 To UBound(vntValues, 2)) For lngRow = 1 To UBound(vntValues, 1) For lngCol = 1 To UBound(vntValues, 2) If vntValues(lngRow, lngCol) <> Empty Then vntRet(lngRow, lngCol) = Application.CountIf(rng, vntValues(lngRow, lngCol)) End If Next Next Sheets("Tabelle2").Range(rng.Address) = vntRet Debug.Print Timer - t Set rng = Nothing End Sub

Sub A1test() Dim arr, myDic As Object, out() Dim L As Long, I As Integer, t As Double t = Timer Set myDic = CreateObject("Scripting.Dictionary") arr = Sheets("Tabelle1").Range("A1:ALL1000") For L = 1 To UBound(arr) For I = 1 To UBound(arr, 2) If Not IsEmpty(arr(L, I)) Then myDic(arr(L, I)) = myDic(arr(L, I)) + 1 End If Next Next ReDim out(1 To UBound(arr), 1 To UBound(arr, 2)) For L = 1 To UBound(arr) For I = 1 To UBound(arr, 2) out(L, I) = myDic(arr(L, I)) Next Next Sheets("Tabelle2").Range("A1:ALL1000") = out Sheets("Tabelle1").Range("A1") = Timer - t End Sub Sub A2Zaehlen() Dim rng As Range Dim lngCol As Long, lngRow As Long Dim vntValues As Variant, vntRet() As Variant Dim t As Double t = Timer Set rng = Sheets("Tabelle1").Range("A1:ALL1000") vntValues = rng ReDim vntRet(1 To UBound(vntValues, 1), 1 To UBound(vntValues, 2)) For lngRow = 1 To UBound(vntValues, 1) For lngCol = 1 To UBound(vntValues, 2) If vntValues(lngRow, lngCol) Empty Then vntRet(lngRow, lngCol) = Application.CountIf(rng, vntValues(lngRow, lngCol)) End If Next Next Sheets("Tabelle2").Range(rng.Address) = vntRet Sheets("Tabelle1").Range("B1") = Timer - t Set rng = Nothing End Sub

Beliebteste Forumthreads (12 Monate)

Schnell sehr viele Formeln ins Blatt schreiben

9
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

306 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Schnell sehr viele Formeln ins Blatt schreiben

9 Beiträge zum Forumthread Beiträge zu diesem Forumthread

306 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

9
Beiträge zum Forumthread

Beiträge zu diesem Forumthread