Datenaustausch

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Sub AUSTAUSCH() Dim aktWB As String Dim ws As String Dim wb As Workbook Dim lngZ As Long Dim strFileName Dim strFilter As String aktWB = ActiveWorkbook.Name ws = Range("N_Austausch") strFilter = "Excel-Dateien(*.xlsm*), *.xlsm*" ChDrive "C" ChDir "C:\Users\Computer\Desktop" strFileName = Application.GetOpenFilename(strFilter) If strFileName = False Then Exit Sub Set wb = Workbooks.Open(strFileName) With Workbooks("AUSTAUSCH.xlsm") With .Worksheets(ws) .Cells.Delete Shift:=xlUp .ListObjects.Add(xlSrcRange, .Range("$A$1"), , xlYes).Name = "Tabelle1" Workbooks(aktWB).Sheets("LISTE").Range("T_Liste1[#All]").Copy .Range("A1").PasteSpecial xlPasteAll .ListObjects("T_Liste1").Name = "T_" & aktWB .ListObjects("T_" & aktWB).ShowAutoFilterDropDown = False .Cells.EntireColumn.AutoFit Application.CutCopyMode = False End With .Close SaveChanges:=True End With Application.DisplayAlerts = True End Sub

Hallo Steve,
das könnte folgendermaßen aussehen (das vom Anwender ausgewählte Verzeichnis wird in F2 von Blatt "Start" gespeichert):

Sub AUSTAUSCH()
Dim anlegen As Long
Dim aktWB As String
Dim pfad As String
Dim ws As String
Dim wsNeu As Worksheet
Dim wsStart As Worksheet
Dim wb As Workbook
Dim wbQ As Workbook
Dim lngZ As Long
Dim strFileName
Dim strFilter As String
Set wbQ = ThisWorkbook
aktWB = wbQ.Name
Set wsStart = wbQ.Worksheets("START")
ws = wsStart.Range("N_Austausch")
strFilter = "Excel-Dateien(*.xlsm*), *.xlsm*"
If IsEmpty(wsStart.Range("F2")) Then
ChDrive "C"
ChDir "C:\Users\Computer\Desktop"
Else
ChDir wsStart.Range("F2")
End If
strFileName = Application.GetOpenFilename(strFilter)
If strFileName = False Then Exit Sub
Set wb = Workbooks.Open(strFileName)
pfad = wb.Path & "\"
' Ausgewähltes Verzeichnis speichern
wsStart.Range("F2") = pfad
wbQ.Save
If BlattExistiert(Mappe:=wb, _
Blattname:=ws) Then
' Blatt ist vorhanden
Set wsNeu = wb.Worksheets(ws)
Else
' Blatt ist nicht vorhanden
anlegen = MsgBox(Prompt:="Soll das Blatt """ & ws & """ angelegt werden?", _
Buttons:=vbYesNo + vbQuestion)
If anlegen = vbNo Then
MsgBox "Ausstieg"
Exit Sub
Else
Set wsNeu = wb.Worksheets.Add(After:=wb.Worksheets(wb.Worksheets.Count))
End If
End If
With wsNeu
.Cells.Delete Shift:=xlUp
.ListObjects.Add(xlSrcRange, .Range("$A$1"), , xlYes).Name = "Tabelle1"
wbQ.Sheets("LISTE").Range("T_Liste1[#All]").Copy
.Range("A1").PasteSpecial xlPasteAll
.ListObjects("T_Liste1").Name = "T_" & aktWB
.ListObjects("T_" & aktWB).ShowAutoFilterDropDown = False
.Cells.EntireColumn.AutoFit
Application.CutCopyMode = False
End With
wb.Close SaveChanges:=True
Application.DisplayAlerts = True
End Sub
Function BlattExistiert(Mappe As Workbook, _
Blattname As String) As Boolean
Dim sh As Object
For Each sh In Mappe.Sheets
If UCase$(sh.Name) = UCase$(Blattname) Then
BlattExistiert = True
Exit Function
End If
Next sh
End Function

https://www.herber.de/bbs/user/136548.xlsm
Viele Grüße
Dieter

If BlattExistiert(Mappe:=wb, _ Blattname:=ws) Then ' Blatt ist vorhanden Set wsNeu = wb.Worksheets(ws) Else ' Blatt ist nicht vorhanden anlegen = MsgBox(Prompt:="Soll das Blatt """ & ws & """ angelegt werden?", _ Buttons:=vbYesNo + vbQuestion) If anlegen = vbNo Then MsgBox "Ausstieg" Exit Sub Else Set wsNeu = wb.Worksheets.Add(After:=wb.Worksheets(wb.Worksheets.Count)) wsNeu.Name = ws End If End If

Hallo Dieter,
danke für den Hinweis - habe ich direkt mal umgesetzt - und den Tipp mit der Dateiendung.
Den hebe ich mir mal auf. Brauche ich sicherlich noch einmal.
Ich habe übrigens einen dusseligen Fehler gemacht. Als ich meine Beispieldatei gesendet habe, war die nur zum Teil so aufgebaut wie das Original. War nicht weiter schlimm. Ich habe das alles anpassen können, aber es sind ein paar Fragen, wahrscheinlich aus Unkenntnis, aufgekommen.
Set wsStart = wbQ.Worksheets("DATEN") 'bei deiner Version war es noch "START"
ws = wsStart.Range("N_Austausch")
Wenn ich das richtig verstehe, dann steht da letztlich N_Austausch befindet sich im Sheet "DATEN".
N_Austausch ist ja eine mit Namen versehene Zelle, deshalb habe ich bisher immer darauf verzichtet letztlich festzulegen wo diese sich befindet. Kannst du mir erklären was es damit auf sich hat?
Den gespeicherten Pfad hast du in F2 angelegt. Den zu verändern ist nicht schwer gewesen.
Also hab ich ihn in das Sheet DATEN in B7 verlegt. (Bis hierhing funktioniert auch alles.)
Dann habe ich für diese Zelle ebenfalls einen Namen vergeben.
Ziel der dynamischen Namen ist, das diese Zellen später, wenn das Layout vergeben werden soll, verschoben werden können ohne dass das Makro darunter leidet.
Habe den Namen vergeben, ihn als String deklariert und dann genauso behandelt wie die Austauschzelle:
lpf = wsStart.Range("N_lpfad")
Dann habe ich die Stellen mit "B7" entsprechend ersetzt. Leider funktioniert das nicht. Kannst du mir sagen was ich da falsch mache?
Ich hänge die Datei mal in geänderter Form an.
https://www.herber.de/bbs/user/136699.xlsm
Da das Original vorsieht, dass das Sheet DATEN ausgeblendet und geschützt ist, habe ich das nun ebenfalls gemacht. Habe in das Makro mit eingebaut, das der Schutz aufgehoben und wieder gesetzt wird.
Wenn ich das richtig verstanden habe, ist das einblenden des Sheets ja nicht zwingend erforderlich - korrekt?
Liebe Grüße
Steve

Beliebteste Forumthreads (12 Monate)

13 Beiträge zum Forumthread Beiträge zu diesem Forumthread

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

13
Beiträge zum Forumthread

Beiträge zu diesem Forumthread