Excel VBA

[Daniela_05d542]

Liebe/-r wer-weiss-was Experte/-in,
ich exportiere aus dem Programm Cobra Adress Plus die beiden Spalten ID + Telefonnummer aus der Rechnungsdatenbank.
Diese Kunden sollen in der zeitlichen Reihenfolge Ihrer ERSTEN Aufträge noch mal per Telefon kontaktiert werden. In der darauffolgenden Woche werden alle neuen Kunden der Vorwoche kontaktiert + dann regelmäßig auch noch mal alle früheren Kunden - wobei die ID die zeitliche Reihenfolge bestimmt.
Ich benötige also ein Makro, dass nach dem Export (Excel, Access…) alle Dubletten bis auf die erste Telefonnummer entfernt unter Beibehaltung der ID.
Ein solches Makro habe ich für Excel schon, allerdings muss irgendwo in meinem Export ein fehlerhafter Wert sein, denn er bringt mir die Fehlermeldung Laufzeitfehler 13: Typen unverträglich.
Es sind 40.000 Datensätze, so das Excel auch bald an seine Grenzen stoßen wird. Die Fehlermeldung wird mir nicht mehr gebracht, wenn ich die Datensätze etwas über 5.000 lösche. Kopiere ich aber die ersten Datensätze noch mal + füge sie ein, dann läuft das Makro auch problemlos über mehr Datensätze.
Wie kann ich denn die Zeile finden, in der sich der fehlerhafte Wert aus dem Export befindet, damit ich ihn entfernen kann + damit das Makro reibungslos durchläuft?
Ich habe gute Office-Kenntnisse, kenne mich aber mit VBA, SQL usw. nicht aus - kann nur Anweisungen befolgen.
Das momentane Makro habe ich auch über ein Forum bekommen, aber dort kann mir keiner mehr weiterhelfen.
Ich brauche dringend Hilfe - das Problem wird immer brenzliger…
Hier schicke ich mal das Makro (in eckigen Klammern ist die Stelle, die mir beim Debuggen angezeigt wird):
Option Explicit

Sub DoppelteAde()
Dim arr As Variant
Dim Dic As Object
Dim i As Long

Set Dic = CreateObject(„Scripting.Dictionary“)

With Worksheets(„Quelle“) 'ANPASSEN
arr = .Range(„A1:B“ & .Cells(.Rows.Count, 1).End(xlUp).Row)
End With

For i = 1 To UBound(arr)
If arr(i, 2) „“ Then
If Not Dic.Exists(arr(i, 2)) Then
Dic(arr(i, 2)) = arr(i, 1)
End If
End If
Next

With Worksheets(„Ziel“) 'ANPASSEN
If Dic.Count > 0 Then
.Range(„A:B“).ClearContents
[.Range(„A1“).Resize(Dic.Count) = _
WorksheetFunction.Transpose(Dic.Items)]
.Range(„B1“).Resize(Dic.Count) = _
WorksheetFunction.Transpose(Dic.Keys)
End If
End With
End Sub
Über baldige Hilfe würde ich mich sehr freuen.
LG von Daniela

[Anonym_5b813eba76fe]

Sorry Daniela,
das ist zu komplex, um, ohne das Programm und dessen Umgebung vorliegen zu haben, eine Lösung zu finden.
Anscheinend hängt es an der aufgerufenen Funktion. Aber was des Fehler genau verursacht, kann man aus der Entfernung nicht feststellen.
Gruß,
Ptonka

[Bei dieser Antwort wurde das Vollzitat nachträglich automatisiert entfernt]

[Hans_J_rgen_a9c080]

Hallo Daniela,

bin gerade erst von einem Kundenbesuch zurückgekommen - dAntwort dauert, da ich mich erst mal mit dem Code auseinandersetzen muß!

Gruß

Jürgen

[Bei dieser Antwort wurde das Vollzitat nachträglich automatisiert entfernt]

[Thomas_Ramel]

Grüezi Daniela

Ich benötige also ein Makro, dass nach dem Export (Excel,
Access…) alle Dubletten bis auf die erste Telefonnummer
entfernt unter Beibehaltung der ID.
Ein solches Makro habe ich für Excel schon, allerdings muss
irgendwo in meinem Export ein fehlerhafter Wert sein, denn er
bringt mir die Fehlermeldung Laufzeitfehler 13: Typen
unverträglich.
Es sind 40.000 Datensätze, so das Excel auch bald an seine
Grenzen stoßen wird. Die Fehlermeldung wird mir nicht mehr
gebracht, wenn ich die Datensätze etwas über 5.000 lösche.

Ja, das ist korrekt - die Transpose()-Methode kann maximal 5461 Elemente transponieren.

Im Dictionary-Objekt werden alle unterschiedlichen ID’s aufgenommen, was bei 40000 einzelnen Werten gut und gerne mehr als 8461 unterschiedliche sein können.

Kopiere ich aber die ersten Datensätze noch mal + füge sie
ein, dann läuft das Makro auch problemlos über mehr
Datensätze.

Ja, klar, denn dann hast Du 0 Then

.Range(„A:B“).ClearContents
[.Range(„A1“).Resize(Dic.Count) = _
WorksheetFunction.Transpose(Dic.Items)]

TransposeDim(Dic.Items))

.Range(„B1“).Resize(Dic.Count) = _
WorksheetFunction.Transpose(Dic.Keys)
End If
End With

Damit sollte dann der Grösse von Daten keine Grenze mehr gesetzt sein.

Mit freundlichen Grüssen

Thomas Ramel

• MVP für MS-Excel -

[Daniela_05d542]

Hallo Thomas,
vielen Dank für deine schnelle Antwort!
Testen kann ich sie erst morgen, wenn ich wieder an der Arbeit bin.
Also den letzten Teil weiß ich, wo ich ihn einfügen muss, aber kannst du mir noch mal schreiben, wohin ich genau den unteren Teil kopieren bzw. was ich mit ihm überschreiben soll?
LG von Dani

Füge die folgenden Zeilen als Ersatz für die Transpose-Methode
in deine Modul ein.

Public Function TransposeDim(v As Variant) As Variant
Dim X As Long, Y As Long, Xupper As Long, Yupper As Long
Dim tempArray As Variant
Xupper = UBound(v, 2)
Yupper = UBound(v, 1)
ReDim tempArray(Xupper, Yupper)
For X = 0 To Xupper
For Y = 0 To Yupper
tempArray(X, Y) = v(Y, X)
Next Y
Next X
TransposeDim = tempArray
End Function

[Waldemar_Wesner]

Hallo Daniela,

ersetze die zeilen:
.Range(„A1“).Resize(Dic.Count) = _
WorksheetFunction.Transpose(Dic.Items)
.Range(„B1“).Resize(Dic.Count) = _
WorksheetFunction.Transpose(Dic.Keys)

durch diese Schleife:
For i = 0 To Dic.Count - 1
.Range(„A1“).Offset(i, 0) = Dic.Items(i)
.Range(„B1“).Offset(i, 0) = Dic.Keys(i)
Next i
wenn das nich die Lösung für dein Problem ist, dann zumindest eine Lösung die dir deinen „Deffekten“ Datensatz finden Sollte.
Unter Umständen kann diese Schleife jede Menge Zeit brauchen.
An dieser Stelle hilft es das Neuzeichnen der Tabelle auf dem Bildschirm abzuschalten(vor der Schleife):
Application.ScreenUpdating = False
und nach der Schleife wieder einzuschalten
Application.ScreenUpdating = True

Wünsche dir viel Spaß
Waldemar

[Bei dieser Antwort wurde das Vollzitat nachträglich automatisiert entfernt]

[Thomas_Ramel]

Grüezi Daniela

vielen Dank für deine schnelle Antwort!

Aber gerne doch

Also den letzten Teil weiß ich, wo ich ihn einfügen muss, aber
kannst du mir noch mal schreiben, wohin ich genau den unteren
Teil kopieren bzw. was ich mit ihm überschreiben soll?

Überschreiben sollst Du nichts, bloss die Zeilen so wie sie sind in ein allgemenies Modul deiner Mappe kopieren. Am einfachsten wird es sein, wenn Du sie einfach unter den bisherigen Code kopierst.

Mit freundlichen Grüssen

Thomas Ramel

• MVP für MS-Excel -

[Daniela_05d542]

Hallo Thomas,
ich benötige dringend deine Hilfe!
Ich habe alle deine Zeilen, so wie du es geschrieben hast unter meinen Code kopiert, aber an der Fehlermeldung ändert sich nichts. Muss ich nicht die fehlerhaften Stellen in meinem Code mit deinem neuen ersetzen?
Kannst du deinen Code noch mal überprüfen - er meckert mir die Stelle TransposeDim(Dic.Items)) an, dass kein End-Code vorhanden ist:
Public Function TransposeDim(v As Variant) As Variant
Dim X As Long, Y As Long, Xupper As Long, Yupper As Long
Dim tempArray As Variant
Xupper = UBound(v, 2)
Yupper = UBound(v, 1)
ReDim tempArray(Xupper, Yupper)
For X = 0 To Xupper
For Y = 0 To Yupper
tempArray(X, Y) = v(Y, X)
Next Y
Next X
TransposeDim = tempArray
End Function
With Worksheets(„Ziel“) 'ANPASSEN
If Dic.Count > 0 Then
.Range(„A:B“).ClearContents
.Range(„A1“).Resize(Dic.Count) = _
WorksheetFunction.Transpose(Dic.Items)
TransposeDim(Dic.Items))
.Range(„B1“).Resize(Dic.Count) = _
WorksheetFunction.Transpose(Dic.Keys)
End If
End With
LG von Dani

Überschreiben sollst Du nichts, bloss die Zeilen so wie sie
sind in ein allgemenies Modul deiner Mappe kopieren. Am
einfachsten wird es sein, wenn Du sie einfach unter den
bisherigen Code kopierst.

Mit freundlichen Grüssen

Thomas Ramel

• MVP für MS-Excel -

[Daniela_05d542]

Nochmals hallo Thomas, ;o)
kannst du mir nicht aus meinem:

Sub DoppelteAde()
Dim arr As Variant
Dim Dic As Object
Dim i As Long
Set Dic = CreateObject(„Scripting.Dictionary“)
With Worksheets(„Quelle“) 'ANPASSEN
arr = .Range(„A1:B“ & .Cells(.Rows.Count,
1).End(xlUp).Row)
End With
For i = 1 To UBound(arr)
If arr(i, 2) „“ Then
If Not Dic.Exists(arr(i, 2)) Then
Dic(arr(i, 2)) = arr(i, 1)
End If
End If
Next
With Worksheets(„Ziel“) 'ANPASSEN
If Dic.Count > 0 Then
.Range(„A:B“).ClearContents
[.Range(„A1“).Resize(Dic.Count) = _
WorksheetFunction.Transpose(Dic.Items)]
.Range(„B1“).Resize(Dic.Count) = _
WorksheetFunction.Transpose(Dic.Keys)
End If
End With
End Sub

Und deinem:

Public Function TransposeDim(v As Variant) As Variant
Dim X As Long, Y As Long, Xupper As Long, Yupper As Long
Dim tempArray As Variant
Xupper = UBound(v, 2)
Yupper = UBound(v, 1)
ReDim tempArray(Xupper, Yupper)
For X = 0 To Xupper
For Y = 0 To Yupper
tempArray(X, Y) = v(Y, X)
Next Y
Next X
TransposeDim = tempArray
End Function
With Worksheets(„Ziel“) 'ANPASSEN
If Dic.Count > 0 Then
.Range(„A:B“).ClearContents
.Range(„A1“).Resize(Dic.Count) = _
WorksheetFunction.Transpose(Dic.Items)
TransposeDim(Dic.Items))
.Range(„B1“).Resize(Dic.Count) = _
WorksheetFunction.Transpose(Dic.Keys)
End If
End With

einen kompletten Code basteln, mit dem ich meinem ganz überschreiben kann?
LG von Dani

[Daniela_05d542]

Hallo Jürgen,
würde mich sehr freuen, wenn du mir helfen könntest.
LG von Dani

Hallo Daniela,

bin gerade erst von einem Kundenbesuch zurückgekommen -
dAntwort dauert, da ich mich erst mal mit dem Code
auseinandersetzen muß!

Gruß

Jürgen

[Thomas_Ramel]

Grüezi Daniela

Ich kann den Code zwar nicht testen, habe ihn dir aber zusammengebaut, sodass Du ihn 1:1 ersetzen kannst:

Sub DoppelteAde()
Dim arr As Variant
Dim Dic As Object
Dim i As Long
Set Dic = CreateObject(„Scripting.Dictionary“)
With Worksheets(„Quelle“) 'ANPASSEN
arr = .Range(„A1:B“ & .Cells(.Rows.Count, 1).End(xlUp).Row)
End With
For i = 1 To UBound(arr)
If arr(i, 2) „“ Then
If Not Dic.Exists(arr(i, 2)) Then
Dic(arr(i, 2)) = arr(i, 1)
End If
End If
Next
With Worksheets(„Ziel“) 'ANPASSEN
If Dic.Count > 0 Then
.Range(„A:B“).ClearContents
.Range(„A1“).Resize(Dic.Count) = _
TransposeDim(Dic.Items)
.Range(„B1“).Resize(Dic.Count) = _
WorksheetFunction.Transpose(Dic.Keys)
End If
End With
End Sub

Public Function TransposeDim(v As Variant) As Variant
Dim X As Long, Y As Long, Xupper As Long, Yupper As Long
Dim tempArray As Variant
Xupper = UBound(v, 2)
Yupper = UBound(v, 1)
ReDim tempArray(Xupper, Yupper)
For X = 0 To Xupper
For Y = 0 To Yupper
tempArray(X, Y) = v(Y, X)
Next Y
Next X
TransposeDim = tempArray
End Function

Ich bin nun den Rest des Tages weg und kann allenfalls abends wieder hier vorbeischauen - ich denke jedoch, dass es klappen sollte *hoff*

Mit freundlichen Grüssen

Thomas Ramel

• MVP für MS-Excel -

[Daniela_05d542]

Hallo Thomas,
du musst heute Abend oder morgen bitte noch mal schauen:
Jetzt bringt er Laufzeitfehler 9: Index außerhalb des gültigen Bereichs.
Beim Debuggen macht er diese Zeile gelb: Xupper = UBound(v, 2)
LG von Dani

Ich bin nun den Rest des Tages weg und kann allenfalls abends
wieder hier vorbeischauen - ich denke jedoch, dass es klappen
sollte *hoff*

Mit freundlichen Grüssen

Thomas Ramel

• MVP für MS-Excel -

[Rainer_Engelhardt_ad43bf]

Tut mir leid, da kenne ich mich nicht gut genug aus. Vielleicht weiß jemand anders mehr, viel Erfolg
Rainer

[Peter_David_McWilliams]

Daniela,

ohne Eingabedatei ist das on hier aus schwer zu sagen, und ohne Kommentar ist jedes Programm eigentlich unverstaendlich…

Untersuche die Datei, ob es einen Null-Wert irgendwo gibt. Oder, falls eine Excel-Datei dann mir zuschicken (bitte gezippt!).

Pete

[Bei dieser Antwort wurde das Vollzitat nachträglich automatisiert entfernt]

[Bodo_KH_L_ck]

.

LG von Daniela

Liebe Daniela,
bitte sende mir zumindest einen Teil Deiner Excel Tabelle (einschließlich der Makros) zu, damit ich sehen kann, was die Makros in Deiner Tabelle genau machen. Danach sehen wir weiter!
Gruß
Bodo

[Daniela_05d542]

Hallo Bodo,
wie kann ich sie dir schicken - gibt es hier irgendwo die Möglichkeit einen Anhang beizufügen?
LG von Dani

Liebe Daniela,
bitte sende mir zumindest einen Teil Deiner Excel Tabelle
(einschließlich der Makros) zu, damit ich sehen kann, was die
Makros in Deiner Tabelle genau machen. Danach sehen wir
weiter!
Gruß
Bodo

[Daniela_05d542]

Hallo Jürgen,
hier die Auflösung, falls sie dich interessiert (dabei ist allerdings zu beachten, dass die Quelle richtig sortiert sein muss - erst nach Telefonnummer + darin dann nach ID, weil das Makro nicht selbst ermittelt, welches die niedrigste ID ist, sondern nur die Zeile stehen lässt, die er zuerst findet + alle restlichen Dublikate rausschmeißt):

Sub DoppelteAde()
Dim arr As Variant
Dim Dic As Object
Dim i As Long

Set Dic = CreateObject(„Scripting.Dictionary“)

With Worksheets(„Quelle“) 'ANPASSEN
arr = .Range(„A1:B“ & .Cells(.Rows.Count, 1).End(xlUp).Row)
End With

For i = 1 To UBound(arr)
If arr(i, 2) „“ Then
If Not Dic.Exists(arr(i, 2)) Then
Dic(arr(i, 2)) = arr(i, 1)
End If
End If
Next

With Worksheets(„Ziel“) 'ANPASSEN
If Dic.Count > 0 Then
.Range(„A1“).Resize(Dic.Count) = _
TransposeDim(Dic.Items)
.Range(„B1“).Resize(Dic.Count) = _
TransposeDim(Dic.Keys)
End If
End With
End Sub

Private Function TransposeDim(v As Variant) As Variant
Dim i As Long
Dim tempArray As Variant
Debug.Print Join(v, „,“)
ReDim tempArray(1 To UBound(v) + 1, 1 To 1)
For i = 0 To UBound(v)
tempArray(i + 1, 1) = v(i)
Next
TransposeDim = tempArray
End Function

LG von Dani
P.S.: Die Lösung war, dass die Limitation der Transpose-Funktion von nur 5.461 Elementen aufgehoben werden musste.

[Daniela_05d542]

Hallo Jürgen,
hier die Auflösung, falls sie dich interessiert (dabei ist allerdings zu beachten, dass die Quelle richtig sortiert sein muss - erst nach Telefonnummer + darin dann nach ID, weil das Makro nicht selbst ermittelt, welches die niedrigste ID ist, sondern nur die Zeile stehen lässt, die er zuerst findet + alle restlichen Dublikate rausschmeißt):

Sub DoppelteAde()
Dim arr As Variant
Dim Dic As Object
Dim i As Long

Set Dic = CreateObject(„Scripting.Dictionary“)

With Worksheets(„Quelle“) 'ANPASSEN
arr = .Range(„A1:B“ & .Cells(.Rows.Count, 1).End(xlUp).Row)
End With

For i = 1 To UBound(arr)
If arr(i, 2) „“ Then
If Not Dic.Exists(arr(i, 2)) Then
Dic(arr(i, 2)) = arr(i, 1)
End If
End If
Next

With Worksheets(„Ziel“) 'ANPASSEN
If Dic.Count > 0 Then
.Range(„A1“).Resize(Dic.Count) = _
TransposeDim(Dic.Items)
.Range(„B1“).Resize(Dic.Count) = _
TransposeDim(Dic.Keys)
End If
End With
End Sub

Private Function TransposeDim(v As Variant) As Variant
Dim i As Long
Dim tempArray As Variant
Debug.Print Join(v, „,“)
ReDim tempArray(1 To UBound(v) + 1, 1 To 1)
For i = 0 To UBound(v)
tempArray(i + 1, 1) = v(i)
Next
TransposeDim = tempArray
End Function

LG von Dani
P.S.: Die Lösung war, dass die Limitation der Transpose-Funktion von nur 5.461 Elementen aufgehoben werden musste…

[Daniela_05d542]

Hallo Pete,
hier die Auflösung, falls sie dich interessiert (dabei ist allerdings zu beachten, dass die Quelle richtig sortiert sein muss - erst nach Telefonnummer + darin dann nach ID, weil das Makro nicht selbst ermittelt, welches die niedrigste ID ist, sondern nur die Zeile stehen lässt, die er zuerst findet + alle restlichen Dublikate rausschmeißt):

Sub DoppelteAde()
Dim arr As Variant
Dim Dic As Object
Dim i As Long

Set Dic = CreateObject(„Scripting.Dictionary“)

With Worksheets(„Quelle“) 'ANPASSEN
arr = .Range(„A1:B“ & .Cells(.Rows.Count, 1).End(xlUp).Row)
End With

For i = 1 To UBound(arr)
If arr(i, 2) „“ Then
If Not Dic.Exists(arr(i, 2)) Then
Dic(arr(i, 2)) = arr(i, 1)
End If
End If
Next

With Worksheets(„Ziel“) 'ANPASSEN
If Dic.Count > 0 Then
.Range(„A1“).Resize(Dic.Count) = _
TransposeDim(Dic.Items)
.Range(„B1“).Resize(Dic.Count) = _
TransposeDim(Dic.Keys)
End If
End With
End Sub

Private Function TransposeDim(v As Variant) As Variant
Dim i As Long
Dim tempArray As Variant
Debug.Print Join(v, „,“)
ReDim tempArray(1 To UBound(v) + 1, 1 To 1)
For i = 0 To UBound(v)
tempArray(i + 1, 1) = v(i)
Next
TransposeDim = tempArray
End Function

LG von Dani
P.S.: Die Lösung war, dass die Limitation der Transpose-Funktion von nur 5.461 Elementen aufgehoben werden musste.

[Daniela_05d542]

Hallo Bodo,
hier die Auflösung, falls sie dich interessiert (dabei ist allerdings zu beachten, dass die Quelle richtig sortiert sein muss - erst nach Telefonnummer + darin dann nach ID, weil das Makro nicht selbst ermittelt, welches die niedrigste ID ist, sondern nur die Zeile stehen lässt, die er zuerst findet + alle restlichen Dublikate rausschmeißt):

Sub DoppelteAde()
Dim arr As Variant
Dim Dic As Object
Dim i As Long

Set Dic = CreateObject(„Scripting.Dictionary“)

With Worksheets(„Quelle“) 'ANPASSEN
arr = .Range(„A1:B“ & .Cells(.Rows.Count, 1).End(xlUp).Row)
End With

For i = 1 To UBound(arr)
If arr(i, 2) „“ Then
If Not Dic.Exists(arr(i, 2)) Then
Dic(arr(i, 2)) = arr(i, 1)
End If
End If
Next

With Worksheets(„Ziel“) 'ANPASSEN
If Dic.Count > 0 Then
.Range(„A1“).Resize(Dic.Count) = _
TransposeDim(Dic.Items)
.Range(„B1“).Resize(Dic.Count) = _
TransposeDim(Dic.Keys)
End If
End With
End Sub

Private Function TransposeDim(v As Variant) As Variant
Dim i As Long
Dim tempArray As Variant
Debug.Print Join(v, „,“)
ReDim tempArray(1 To UBound(v) + 1, 1 To 1)
For i = 0 To UBound(v)
tempArray(i + 1, 1) = v(i)
Next
TransposeDim = tempArray
End Function

LG von Dani
P.S.: Die Lösung war, dass die Limitation der Transpose-Funktion von nur 5.461 Elementen aufgehoben werden musste.