2.9k Aufrufe
Gefragt in Tabellenkalkulation von
Hallo zusammen,

ich stehe vor folgender Herrausforderung:

ich gebe verschiedenen Materialnummern 4 Eigenschaften in einer Excel-Tabelle.
ein Kollege macht das gleiche für ein anderes Produkt in einer seperaten Excel-Tabelle.
Hierbei kommt auch eine Schnittmenge auf, bei der wir uns abstimmen müssen.

Meine Aufgabe ist es jetzt eine übergeordnete Tabelle zu erstellen.

Hiebei soll ein Sheet genau meiner Tabelle entsprechen, ein Sheet der Tabelle meines Kollegen entsprechen und der dritte Sheet soll diese vergleichen in dem aufzeigt welche Nummern bei beiden vorkommen und wie dessen 4 Eigenschaften sind.

DIESES SOLL AUTOMATSICH AKTUALISIERT SEIN.

sprich wenn ich 10 weitere Materialnummern in meiner Tabelle eintrage sollen die automatsich auch in der Übergeordneten Tabelle erscheinen und verglichen warden.

Ist für mich als normaler Anwender echt eine Herkulesaufgabe. Kann mit jemand weiterhelfen ???? ;/

8 Antworten

0 Punkte
Beantwortet von m-o Profi (15.6k Punkte)
Hallo,

ich gehe mal davon aus, dass bei beiden zu vergleichenden Tabellen die Materialnummern in Spalte A stehen und die Eigenschaften in den Spalten B bis E und dass in der ersten Zeile eine Überschrift steht.

Füge in ein Standard-Modul der betreffenden Arbeitsmappe den folgenden Code ein:

Sub vergleich()

Dim i As Integer
Dim bExists As Boolean
Dim strTab1 As String
Dim strTab2 As String
Dim strSchnitt As String
Dim lngLetzte1 As Long
Dim lngLetzte2 As Long
Dim lngZeile1 As Long
Dim lngZeile2 As Long
Dim lngZaehler As Long

'Name der beiden Arbeitsblätter festlegen, die vergleichen werden sollen
strTab1 = "Tabelle1"
strTab2 = "Tabelle2"

'Name des Arbeitsblatts für die Schnittmenge
strSchnitt = "Schnittmenge"

'Bildschirmaktualisierung ausschalten:
Application.ScreenUpdating = False

For i = 1 To ThisWorkbook.Sheets.Count
If Sheets(i).Name = strSchnitt Then
bExists = True: Exit For
End If
Next i

If bExists Then
' ... wenn ja: vorhandene Daten löschen
lngLetzte1 = ThisWorkbook.Worksheets(strSchnitt).Cells(Rows.Count, 1).End(xlUp).Row
With ThisWorkbook.Worksheets(strSchnitt)
.Range(.Cells(2, 1), .Cells(lngLetzte1, 7)).ClearContents
End With
Else
' ... wenn nein: ein solches Blatt erstellen.
'Neues Blatt wird am Ende eingefügt
Worksheets.Add After:=Worksheets(Worksheets.Count)
'Neues Blatt benennen
ActiveSheet.Name = strSchnitt
'und einrichten
With ThisWorkbook.Worksheets(strSchnitt)
.Range("A1") = "Tabelle"
.Range("B1") = "Zeilennummer"
.Range("C1") = "Materialnummer"
.Range("D1") = "Eigenschaft 1"
.Range("E1") = "Eigenschaft 2"
.Range("F1") = "Eigenschaft 3"
.Range("G1") = "Eigenschaft 4"
End With
End If

'jeweils die letzten Zeilen auf den beiden Tabellen ermitteln
lngLetzte1 = ThisWorkbook.Worksheets(strTab1).Cells(Rows.Count, 1).End(xlUp).Row
lngLetzte2 = ThisWorkbook.Worksheets(strTab2).Cells(Rows.Count, 1).End(xlUp).Row

'Zähler für Einfügezeilen Schnittmenge setzen
lngZaehler = 1

'Vergleichen
For lngZeile1 = 2 To lngLetzte1
For lngZeile2 = 2 To lngLetzte2
If ThisWorkbook.Worksheets(strTab1).Cells(lngZeile1, 1) = ThisWorkbook.Worksheets(strTab2).Cells(lngZeile2, 1) Then
lngZaehler = lngZaehler + 1
With ThisWorkbook.Worksheets(strSchnitt)
.Cells(lngZaehler, 1) = strTab1 'Tabellennamen
.Cells(lngZaehler + 1, 1) = strTab2
.Cells(lngZaehler, 2) = lngZeile1 'Zeilennummern
.Cells(lngZaehler + 1, 2) = lngZeile2
End With

For i = 1 To 5
ThisWorkbook.Worksheets(strSchnitt).Cells(lngZaehler, 2 + i) = ThisWorkbook.Worksheets(strTab1).Cells(lngZeile1, i)
ThisWorkbook.Worksheets(strSchnitt).Cells(lngZaehler + 1, 2 + i) = ThisWorkbook.Worksheets(strTab2).Cells(lngZeile2, i)
Next i

lngZaehler = lngZaehler + 2

End If

Next lngZeile2

Next lngZeile1

'auf Tabelle mit Schnittmenge wechseln
ThisWorkbook.Worksheets(strSchnitt).Activate

'Bildschirmaktualisierung einschalten:
Application.ScreenUpdating = True

End Sub


Die Namen der betreffenden Arbeitsblätter musst du natürlich auf deine Verhältnisse anpassen.

Wenn du willst, dass der Code automatisch, z.B. beim Speichern der Tabelle, ausgeführt wird, dann schreibe in das VBA-Projekt der Arbeitsmappe den folgenden Code:

Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)

Call vergleich

End Sub


Den Vergleichscode kannst du so auch "per Hand" starten.

Gruß

M.O.
0 Punkte
Beantwortet von
Herzlichen Dank M.O. für deine Hilfe und sehr ausführliche Antwort.
Da ich im Studium bisschen mit Java und C++ gearbeitet habe kann ich deine schritte einger Maßen nachvollziehen.
Hast dir echt Mühe gegeben es so sauber wie möglich zu schreiben. Vielen Dank.

Die Aufgabe des Vergleichs ware mit diesem Makro gelöst.

Mein Problem ist nur dass der Inhalt der zu vergleichenden Arbeitsblätter erstmal in diese übergeordnete Datei eingespielt werden muss.

Ausgangssituation ist also dass ich eine Datei (XXXX.xlsx) bzw Tabelle habe und mein Kollege eine Datei (YYYY.xlsx) hat.
Und diese Inhalte beider Dateien müssten erstmal in die übergeordnete Datei (Vergleich.xlsx) in zwei Arbeitsblätter eingespielt warden.

Ist dies möglich? und ist damit gewährleistet dass mit dem abspielen des Makros die Listen auf aktuellem Stand nach einer Änderung in der Quelldatei sind?

Hoffe du kennst da auch eine Lösung M.O. wäre ein Traum :)
0 Punkte
Beantwortet von m-o Profi (15.6k Punkte)
Hallo,

auch das kann man über VBA lösen. Ich gehe mal davon aus, dass die Dateien XXXX.xlsx und YYYY.xlsx im selben Verzeichnis, wie die Datei "Vergleich" liegen (ansonsten müsste man das folgende Makro entsprechend modifizieren, was aber auch kein Problem ist).
Kopiere das Makro in das VBA-Projekt der Arbeitsmappe "Vergleich" (lösche aber alle anderen Makros zuerst aus der Arbeitsmappe, soweit sie sich auf den Vergleich beziehen):

Private Sub Workbook_Open()

Dim i As Integer
Dim bExists As Boolean
Dim strName1 As String
Dim strName2 As String
Dim strSchnitt As String
Dim lngLetzte1 As Long
Dim lngLetzte2 As Long
Dim lngZeile1 As Long
Dim lngZeile2 As Long
Dim lngZaehler As Long
Dim strPfad As String
Dim strDatei As String

'Bildschirmaktualisierung ausschalten:
Application.ScreenUpdating = False

'keine Meldungen anzeigen
Application.DisplayAlerts = False

'die beiden zu importierenden Dateien liegen im gleichen Verzeichnis wie die Datei Vergleich
strPfad = ThisWorkbook.Path & "\"

'Namen der zu öffnenden Dateien
strName1 = "XXXX.xlsx"
strName2 = "YYYY.xlsx"

'Name des Arbeitsblatts für die Schnittmenge
strSchnitt = "Schnittmenge"

'Prüfen ob Tabellenblätter bereits vorhanden sind und ggf. löschen
For i = Worksheets.Count To 1 Step -1
If Sheets(i).Name = strName1 Or Sheets(i).Name = strName2 Then Sheets(i).Delete
Next i

'1. Datei öffnen
strDatei = strPfad & strName1
Workbooks.Open (strDatei)

'1. Tabellenblatt in Datei Vergleich kopieren
Workbooks(strName1).Sheets(1).Copy after:=ThisWorkbook.Sheets(1)

'geöffnete Datei wieder schließen, ohne speichern
Workbooks(strName1).Close (False)

'importierte Tabelle umbennen
ActiveSheet.Name = strName1

'2. Datei öffnen
strDatei = strPfad & strName2
Workbooks.Open (strDatei)

'1. Tabellenblatt in Datei Vergleich kopieren
Workbooks(strName2).Sheets(1).Copy after:=ThisWorkbook.Sheets(1)

'geöffnete Datei wieder schließen, ohne speichern
Workbooks(strName2).Close (False)

'importierte Tabelle umbennen
ActiveSheet.Name = strName2

For i = 1 To ThisWorkbook.Sheets.Count
If Sheets(i).Name = strSchnitt Then
bExists = True: Exit For
End If
Next i

If bExists Then
' ... wenn ja: vorhandene Daten löschen
lngLetzte1 = ThisWorkbook.Worksheets(strSchnitt).Cells(Rows.Count, 1).End(xlUp).Row
With ThisWorkbook.Worksheets(strSchnitt)
.Range(.Cells(2, 1), .Cells(lngLetzte1, 7)).ClearContents
End With
Else
' ... wenn nein: ein solches Blatt erstellen.
'Neues Blatt wird am Ende eingefügt
Worksheets.Add after:=Worksheets(Worksheets.Count)
'Neues Blatt benennen
ActiveSheet.Name = strSchnitt
'und einrichten
With ThisWorkbook.Worksheets(strSchnitt)
.Range("A1") = "Tabelle"
.Range("B1") = "Zeilennummer"
.Range("C1") = "Materialnummer"
.Range("D1") = "Eigenschaft 1"
.Range("E1") = "Eigenschaft 2"
.Range("F1") = "Eigenschaft 3"
.Range("G1") = "Eigenschaft 4"
End With
End If

'jeweils die letzten Zeilen auf den beiden Tabellen ermitteln
lngLetzte1 = ThisWorkbook.Worksheets(strName1).Cells(Rows.Count, 1).End(xlUp).Row
lngLetzte2 = ThisWorkbook.Worksheets(strName2).Cells(Rows.Count, 1).End(xlUp).Row

'Zähler für Einfügezeilen Schnittmenge setzen
lngZaehler = 1

'Vergleichen
For lngZeile1 = 2 To lngLetzte1
For lngZeile2 = 2 To lngLetzte2
If ThisWorkbook.Worksheets(strName1).Cells(lngZeile1, 1) = ThisWorkbook.Worksheets(strName2).Cells(lngZeile2, 1) Then
lngZaehler = lngZaehler + 1
With ThisWorkbook.Worksheets(strSchnitt)
.Cells(lngZaehler, 1) = strTab1 'Tabellennamen
.Cells(lngZaehler + 1, 1) = strTab2
.Cells(lngZaehler, 2) = lngZeile1 'Zeilennummern
.Cells(lngZaehler + 1, 2) = lngZeile2
End With

For i = 1 To 5
ThisWorkbook.Worksheets(strSchnitt).Cells(lngZaehler, 2 + i) = ThisWorkbook.Worksheets(strName1).Cells(lngZeile1, i)
ThisWorkbook.Worksheets(strSchnitt).Cells(lngZaehler + 1, 2 + i) = ThisWorkbook.Worksheets(strName2).Cells(lngZeile2, i)
Next i

lngZaehler = lngZaehler + 2

End If

Next lngZeile2

Next lngZeile1

'auf Tabelle mit Schnittmenge wechseln
ThisWorkbook.Worksheets(strSchnitt).Activate

'Meldungen wieder anzeigen
Application.DisplayAlerts = True

'Bildschirmaktualisierung einschalten:
Application.ScreenUpdating = True

End Sub


Das Makro wird nun beim Öffnen der Arbeitsmappe Vergleich ausgeführt. Das jeweils erste Tabellenblatt der beiden Dateien XXXX.xlsx und YYYY.xlsx werden in die Mappe kopiert und entsprechend den Mappen benannt. Eventuell vorhandene Arbeitsblätter mit gleichen Namen in der Arbeitsmappe Vergleich werden gelöscht. Danach erfolgt der Vergleich der beiden Datenbestände.

Gruß

M.O.
0 Punkte
Beantwortet von
Danke dir M.O.

ich habe das an einer Testversion probiert und es funktioniert. Weltklasse !

Bei meiner eigentlichen Arbeit hackt es allerdings an der Stelle des Quelldateipfades:
Beim abspielen des Makros erscheint folgende Fehlermeldung:

"Laufzeitfehler '1004'
Microsoft Excel kann auf die Datei
'https://................xlsx' nicht zugreifen. Dies kann mehrere Gründe haben:
-Der Name des Dokumnets oder der Pfad ist nciht vorhanden.
-Das Dokument wird von einem anderen Programm verwendet.
-Der Name der Arbeitsmappe, die gespeichert werden soll, ist identisch zu dem Namen eines anderen Dokuments, welches schreibgeschützt ist."

Ich vermute es liegt daran dass die beiden Quelldateien auf einem SharePoint und nicht auf einem Laufwerk liegen, da mein Kollege in der USA sitzt.
Gibt es die Möglichkeit beim öffnen der Datei das Porgramm so anzupassen, dass es sich die Datei downloaded oder ähnliches?

Ich weiß das wird hier alles schon sehr speziell und du hast mir schon sehr geholfen M.O. aber vielleicht weißt du als Excel-Profi auch hier eine Lösung

Lieben Gruß und Herzlichen Dank M.O.
0 Punkte
Beantwortet von m-o Profi (15.6k Punkte)
Hallo,

mit dem Abruf von Daten aus dem Internet habe ich bisher noch keine Erfahrung. Ich habe mal im Internet etwas recherchiert und einen Code gefunden (http://forum.c*h*i*p.de/office/datei-download-dialog-per-vba-steuern-1188188.html). Die Sterne in c*h*i*p musst du entfernen, da die Seite hier gern zensiert wird.
Probier mal ob mit folgendem Code deine Datei abgerufen werden kann:
Sub GetFile()
Dim folder As String
Dim RowCount As String
Dim oPath As String
Dim oValue As String
folder = ThisWorkbook.Path & "\"

'aktuellen Downloadpfad aus Registry auslesen und in Variable speichern
oPath = RegRead("HKEY_CURRENT_USER\Software\Microsoft\Internet Explorer\Download Directory")

'aktuelle Sicherheitseinstellung für automatische Eingabeaufforderung auslesen und in Variable speichern
oValue = RegRead("HKEY_CURRENT_USER\Software\Microsoft\Windows\CurrentVersion\Internet Settings\Zones\3\2200")

' gewünschten Downloadpfad einstellen und in Registry speichern
RegWrite "HKEY_CURRENT_USER\Software\Microsoft\Internet Explorer\Download Directory", folder, "REG_SZ"

'automatische Eingabeaufforderung aktivieren
RegWrite "HKEY_CURRENT_USER\Software\Microsoft\Windows\CurrentVersion\Internet Settings\Zones\3\2200", "0"

'Warten
Application.Wait (Now + TimeValue("0:00:05"))

'Datei zum Download aufrufen
ActiveWorkbook.FollowHyperlink "https://................xlsx"
'
' Warten
Application.Wait (Now + TimeValue("0:00:10"))
'
'Alt+s - Datei speichern
SendKeys "%s", True

'Warten
Application.Wait (Now + TimeValue("0:00:05"))

'Alt+n - Pfad und Dateiname vorgeben und speichern
SendKeys "%n", True
SendKeys (folder & "1.csv"), True

' Registryeintrag auf auf ursprünglichen Downloadpfad zurücksetzen
RegWrite "HKEY_CURRENT_USER\Software\Microsoft\Internet Explorer\Download Directory", oPath, "REG_SZ"

'ursprüngliche Einstellung für automatische Eingabeaufforderung wiederherstellen
RegWrite "HKEY_CURRENT_USER\Software\Microsoft\Windows\CurrentVersion\Internet Settings\Zones\3\2200", oValue
End Sub

Kopiere den Code in ein Modul deiner Datei Vergleich. Falls das klappt dann kannst du bei meinem geposteten Code am Anfang noch die folgende Zeile ergänzen:

Private Sub Workbook_Open()

Dim i As Integer
Dim bExists As Boolean
Dim strName1 As String
Dim strName2 As String
Dim strSchnitt As String
Dim lngLetzte1 As Long
Dim lngLetzte2 As Long
Dim lngZeile1 As Long
Dim lngZeile2 As Long
Dim lngZaehler As Long
Dim strPfad As String
Dim strDatei As String

'Bildschirmaktualisierung ausschalten:
Application.ScreenUpdating = False

'keine Meldungen anzeigen
Application.DisplayAlerts = False

Call GetFile

'die beiden zu importierenden Dateien liegen im gleichen Verzeichnis wie die Datei Vergleich
strPfad = ThisWorkbook.Path & "\"
....


Weiterhin ist in meinem geposteten Code noch ein kleiner Fehler. Ersetze im Vergleichen-Teil strTab durch strName.
Das sollte dann so aussehen:

'Vergleichen
For lngZeile1 = 2 To lngLetzte1
For lngZeile2 = 2 To lngLetzte2
If ThisWorkbook.Worksheets(strName1).Cells(lngZeile1, 1) = ThisWorkbook.Worksheets(strName2).Cells(lngZeile2, 1) Then
lngZaehler = lngZaehler + 1
With ThisWorkbook.Worksheets(strSchnitt)
.Cells(lngZaehler, 1) = strName1 'Tabellennamen
.Cells(lngZaehler + 1, 1) = strName2
.Cells(lngZaehler, 2) = lngZeile1 'Zeilennummern
.Cells(lngZaehler + 1, 2) = lngZeile2
End With

Gruß
M.O.
0 Punkte
Beantwortet von
bin echt beeindruckt dass du dir beim antworten so viel mühe gibst. vielen dank M.O.

leider bin ich nach vieler Fehlersuche noch nicht zum Ziel gekommen, was wahrscheinlich daran liegt dass ich Anfänger bin und die einfachsten Dinge übersehe.

Es kommt beim Abspielen des Makros immer zur Fehlermeldung "Fehler beim Kompilieren: Sub oder Funktion nicht defniert"
Sodass danach der erste Befehl "RegRead" blau hinterlegt.

Ohne deine HIlfe hätte ich dafür viel länger gebraucht. Kannst du eine Ferndiagnose stellen? habe an sich alles so gemacht wie du es beschrieben hast.
Als kleiner Hinweis: Die Quelldatei liegt (leider) nicht im Internet sondern in einem Intranet (d.h. https:.....)

Liebe Grüße

dan7
0 Punkte
Beantwortet von m-o Profi (15.6k Punkte)
Hallo,
ich habe noch mal etwas gesucht und einen anderen Code gefunden. Bei meinen Test hat der download auch geklappt.

Schau mal ob der folgende Code funktioniert:

Private Sub Workbook_Open()

Dim i As Integer
Dim bExists As Boolean
Dim strName1 As String
Dim strName2 As String
Dim strSchnitt As String
Dim lngLetzte1 As Long
Dim lngLetzte2 As Long
Dim lngZeile1 As Long
Dim lngZeile2 As Long
Dim lngZaehler As Long
Dim strPfad As String
Dim strDatei As String
Dim myURL As String
Dim strSpeicherDatei As String
Dim WinHttpReq As Object

'Bildschirmaktualisierung ausschalten:
Application.ScreenUpdating = False

'keine Meldungen anzeigen
Application.DisplayAlerts = False

'hier URL mit Datei angeben für den download aus dem Intranet
myURL = "http:://...irgendwas.xlsx"

'Namen aus Pfad extrahieren
strName2 = Right(myURL, Len(myURL) - InStrRev(myURL, "/"))

'die beiden zu importierenden Dateien liegen im gleichen Verzeichnis wie die Datei Vergleich
strPfad = ThisWorkbook.Path & "\"

'Pfad und Name der zu speichernden Datei
strSpeicherDatei = strPfad & strName2

'Namen der zu öffnenden eigenen Datei
strName1 = "XXXX.xlsx" 'lokale Datei

'Name des Arbeitsblatts für die Schnittmenge
strSchnitt = "Schnittmenge"

'download der Datei und speichern der Datei
Set WinHttpReq = CreateObject("Microsoft.XMLHTTP")
WinHttpReq.Open "GET", myURL, False, "username", "password"
WinHttpReq.send

myURL = WinHttpReq.responseBody
If WinHttpReq.Status = 200 Then
Set oStream = CreateObject("ADODB.Stream")
oStream.Open
oStream.Type = 1
oStream.Write WinHttpReq.responseBody
oStream.SaveToFile strSpeicherDatei, 2 ' 1 = no overwrite, 2 = overwrite
oStream.Close
End If

'Prüfen ob Tabellenblätter bereits vorhanden sind und ggf. löschen
For i = Worksheets.Count To 1 Step -1
If Sheets(i).Name = strName1 Or Sheets(i).Name = strName2 Then Sheets(i).Delete
Next i

'1. Datei öffnen
strDatei = strPfad & strName1
Workbooks.Open (strDatei)

'1. Tabellenblatt in Datei Vergleich kopieren
Workbooks(strName1).Sheets(1).Copy after:=ThisWorkbook.Sheets(1)

'geöffnete Datei wieder schließen, ohne speichern
Workbooks(strName1).Close (False)

'importierte Tabelle umbennen
ActiveSheet.Name = strName1

'2. Datei öffnen
strDatei = strPfad & strName2
Workbooks.Open (strDatei)

'1. Tabellenblatt in Datei Vergleich kopieren
Workbooks(strName2).Sheets(1).Copy after:=ThisWorkbook.Sheets(1)

'geöffnete Datei wieder schließen, ohne speichern
Workbooks(strName2).Close (False)

'importierte Tabelle umbennen
ActiveSheet.Name = strName2

For i = 1 To ThisWorkbook.Sheets.Count
If Sheets(i).Name = strSchnitt Then
bExists = True: Exit For
End If
Next i

If bExists Then
' ... wenn ja: vorhandene Daten löschen
lngLetzte1 = ThisWorkbook.Worksheets(strSchnitt).Cells(Rows.Count, 1).End(xlUp).Row
With ThisWorkbook.Worksheets(strSchnitt)
.Range(.Cells(2, 1), .Cells(lngLetzte1, 7)).ClearContents
End With
Else
' ... wenn nein: ein solches Blatt erstellen.
'Neues Blatt wird am Ende eingefügt
Worksheets.Add after:=Worksheets(Worksheets.Count)
'Neues Blatt benennen
ActiveSheet.Name = strSchnitt
'und einrichten
With ThisWorkbook.Worksheets(strSchnitt)
.Range("A1") = "Tabelle"
.Range("B1") = "Zeilennummer"
.Range("C1") = "Materialnummer"
.Range("D1") = "Eigenschaft 1"
.Range("E1") = "Eigenschaft 2"
.Range("F1") = "Eigenschaft 3"
.Range("G1") = "Eigenschaft 4"
End With
End If

'jeweils die letzten Zeilen auf den beiden Tabellen ermitteln
lngLetzte1 = ThisWorkbook.Worksheets(strName1).Cells(Rows.Count, 1).End(xlUp).Row
lngLetzte2 = ThisWorkbook.Worksheets(strName2).Cells(Rows.Count, 1).End(xlUp).Row

'Zähler für Einfügezeilen Schnittmenge setzen
lngZaehler = 1

'Vergleichen
For lngZeile1 = 2 To lngLetzte1
For lngZeile2 = 2 To lngLetzte2
If ThisWorkbook.Worksheets(strName1).Cells(lngZeile1, 1) = ThisWorkbook.Worksheets(strName2).Cells(lngZeile2, 1) Then
lngZaehler = lngZaehler + 1
With ThisWorkbook.Worksheets(strSchnitt)
.Cells(lngZaehler, 1) = strName1 'Tabellennamen
.Cells(lngZaehler + 1, 1) = strName2
.Cells(lngZaehler, 2) = lngZeile1 'Zeilennummern
.Cells(lngZaehler + 1, 2) = lngZeile2
End With

For i = 1 To 5
ThisWorkbook.Worksheets(strSchnitt).Cells(lngZaehler, 2 + i) = ThisWorkbook.Worksheets(strName1).Cells(lngZeile1, i)
ThisWorkbook.Worksheets(strSchnitt).Cells(lngZaehler + 1, 2 + i) = ThisWorkbook.Worksheets(strName2).Cells(lngZeile2, i)
Next i

lngZaehler = lngZaehler + 2

End If

Next lngZeile2

Next lngZeile1

'auf Tabelle mit Schnittmenge wechseln
ThisWorkbook.Worksheets(strSchnitt).Activate

'Meldungen wieder anzeigen
Application.DisplayAlerts = True

'Bildschirmaktualisierung einschalten:
Application.ScreenUpdating = True

End Sub


Gruß

M.O.
0 Punkte
Beantwortet von
Habe alles mehrmals überprüft mit dem link usw. aber nun kommt leider wieder die Fehlermeldung von davor :/

"Laufzeitfehler '1004'
Microsoft Excel kann auf die Datei
'https://................xlsx' nicht zugreifen. Dies kann mehrere Gründe haben:
-Der Name des Dokumnets oder der Pfad ist nciht vorhanden.
-Das Dokument wird von einem anderen Programm verwendet.
-Der Name der Arbeitsmappe, die gespeichert werden soll, ist identisch zu dem Namen eines anderen Dokuments, welches schreibgeschützt ist."

Ich weiß nicht ob er dies anzeigt weil er tatsächlich nicht darauf zugreifen kann oder ob die datei zu groß ist. ist sind 25MB und 9 Sheets, von dene aber nur ein Sheet (15000 Zeilen) relevant ist :/

Danke für deine Mühe. Gruß dan7
...