Problem with data import

Könnte vielleicht sein das Excel den SpecialCellsBUG auch beim Kopieren hat, mach mal eine neue Datei und führe das Makro unten darin aus.

Es schreibt ein paar Daten in die Tabelle und setzt einen Autofilter.

Markiere alle sichtbaren Zellen und drückt STRG-C, kommt der Fehler?

Andreas.



Sub SpecialCellsBUG()

Dim Count As Long

Dim Data() As Variant

Dim i As Long

Dim R As Range



'Number of areas (8192 is the limit for Specialcells)

Count = 8193



ReDim Data(1 To Count * 2, 1 To 2)

For i = 1 To UBound(Data)

Data(i, 1) = i \ 2

Data(i, 2) = i Mod 2

Next

Data(1, 1) = "Nr"

Data(1, 2) = "Value"



'Cells.ClearContents

With Range("A1")

.Resize(UBound(Data), UBound(Data, 2)) = Data

.AutoFilter 2, 0

'Set R = .Parent.AutoFilter.Range

End With



'Set R = R.SpecialCells(xlCellTypeVisible)

'R.Select

End Sub

Hallo,



nein, du müsstest vor jede Funktion das WorksheetFunction setzen, also:

=WorksheetFunction.IfError(Worksheetfunction.Countifs....



Ich lasse dann lieber die With-Anweisung für das Blatt weg und referenziere immer auf das Blatt und schreibe dann eine With-Anweisung für die WorksheetFunction:



For Each rngfp In Sheets("FP").Range("D3" & lrowfp)

With WorksheetFunction

rngfp.Value = .IfError(.CountIfs(Sheets("Raw data 48hrs") _

.Range("A2:A" & Lrow48), Sheets("FP").Cells(rngfp.Row, 2), _

Sheets("Raw Data 48hrs").Range("M2:M" & Lrow48), "No"), "")

End With

Next



Mit freundlichen Grüßen

Claus

Hallo Manfred,
<br />vielen Dank für deine Anfrage.
<br />Gehe wie hier beschrieben vor: https://docs.microsoft.com/de-de/microsoft-365/admin/get-help-with-domains/transfer-data-manually.
<br />Ich freue mich auf deine Rückmeldung.
<br />

Okay, also ich probier mal mit Material, Lager und 30 Spalten mit 20.000 Datensätzen und einer Suche die 60 Kombinationen dort rausfiltert.

Mach mal eine neue Datei und lass dies Makro laufen, das erzeugt meinen Datenbestand:

Sub Setup()

Dim Data(1 To 20000, 1 To 32)

Dim Temp

Dim i As Long, j As Long, k As Long

Cells.ClearContents

For i = 1 To UBound(Data)

Do

j = Rnd * 10

Loop Until j > 5

If i + j > UBound(Data) Then j = UBound(Data) - i

k = k + 1

For j = i To i + j

Data(j, 1) = "Mat " & k

Next

i = j - 1

Next

For i = 1 To UBound(Data)

Data(i, 2) = "Lager " & Int(Rnd * 30)

For j = 3 To UBound(Data, 2)

Data(i, j) = Chr(Asc("A") + Rnd * 25)

Next

Next

With Sheets("Tabelle1")

.Cells.ClearContents

.Range("A2").Resize(UBound(Data), UBound(Data, 2)) = Data

ReDim Temp(1 To UBound(Data, 2))

Temp(1) = "Material"

Temp(2) = "Lager"

For i = 3 To UBound(Temp)

Temp(i) = "Spalte " & i - 2

Next

.Range("A1").Resize(1, UBound(Temp)) = Temp

End With

With Sheets("Tabelle2")

.Cells.ClearContents

.Range("A1:B1") = Array("Material", "Lager")

.Range("A2").FormulaLocal = "=INDEX(Tabelle1!A:A;ZUFALLSBEREICH(1;2000))"

.Range("B2").FormulaLocal = "=INDEX(Tabelle1!B:B;ZUFALLSBEREICH(1;2000))"

With .Range("A2:B61")

.FillDown

.Value = .Value

End With

End With

With Sheets("Tabelle3")

.Cells.ClearContents

End With

End Sub

Unten findest Du eine modifizierte Variante Deines Makros, braucht bei mir ca. 1,5 Sekunden um das Ergebnis zu liefern.

Das Zeilen in meinem Beispiel leer bleiben ist kein Fehler, denn es ist wohl auch bei Dir möglich das es manche Kombination aus Material und Lager nicht gibt.

Andreas.

Public Sub machs3()

Dim MyDic As Object

Dim Matrix, Suchkriterium, Ausgabe

Dim L As Long, i As Long, r As Long

Dim Key As String

Set MyDic = CreateObject("Scripting.Dictionary")

With Sheets("Tabelle1")

Matrix = .Range("A1").CurrentRegion

End With

For L = 1 To UBound(Matrix)

Key = Matrix(L, 1) & vbNullChar & Matrix(L, 2)

If Not MyDic.Exists(Key) Then MyDic(Key) = L

Next

With Sheets("Tabelle2")

Suchkriterium = .Range("A1", .Range("B" & Rows.Count).End(xlUp))

End With

ReDim Ausgabe(1 To UBound(Suchkriterium), 1 To UBound(Matrix, 2))

For L = 1 To UBound(Suchkriterium)

Key = Suchkriterium(L, 1) & vbNullChar & Suchkriterium(L, 2)

If MyDic.Exists(Key) Then

r = MyDic(Key)

For i = 1 To UBound(Matrix, 2)

Ausgabe(L, i) = Matrix(r, i)

Next

End If

Next

Sheets("Tabelle3").Range("A1").Resize(UBound(Suchkriterium), UBound(Matrix, 2)) = Ausgabe

End Sub

Hallo,

Danke für die Rückmeldung, werde es mal probieren..

Melde mich dann ob es geklappt hat oder nicht..:-(



Wolfgang