Geöffnete Datei schließen, umbenennen un

Franz (fcs), der leider verstorben ist, hat mir vor 2 Jahren geholfen fmc-Dateien von einer neueren Version in eine ältere Version umzuwandeln, so dass ich mit diesen Daten auf meiner alten CNC arbeiten kann. Dort brauchte ich nur einen Schalter in der Excel-Datei betätigen, der Explorer hat sich dann geöffnet und nach anklicken der gewünschten Datei im Explorer wurde diese geöffnet, die Daten wurden in die Excel Datei eingelesen, nach meinen Angaben geändert, wieder in eine fmc Datei eingelesen und der Dateiname wurde geändert.
Das hat mich zur Idee inspiriert auf ähnliche Weise Dateien zu archivieren. Das ist sicherlich nicht so komplex wie die eben beschriebene Umwandlung. Ich weiß aber nicht, ob es überhaupt mit verschiedenen Dateitypen in einer Anwendung funktioniert.
Für mich als Holzwurm sind die VBA Funktionen noch böhmische Wälder. Wenn ich 20 Jahre jünger wäre, würde ich noch mal die Schulbank drücken.
Ich würde mich sehr freuen, wenn mir einer von euch hierbei helfen könnte.
https://www.herber.de/bbs/user/157129.xlsm

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Sub Schaltfläche26_Klicken() Dim Datum As Variant, Idx As Integer, Notiz As String Dim Datei As String, NeuDatei As String, ok As Variant Dim Archiv As String, NeuTxt As String, DTyp As String If Workbooks.Count = 1 Then MsgBox "Keine neue Datei geöffnet", vbInformation: Exit Sub With ThisWorkbook.Worksheets("Tabellen") Datei = Workbooks(2).Name 'göffnete Datei (nicht aktiv!) If Datei = ThisWorkbook.Name Then Workbooks(1).Name Notiz = ThisWorkbook.Worksheets("Startseite").Range("C9") Datum = Format(.Range("P1"), "dd.mm.yy") 'ComboBoxen Werte in Zeile 1 auslesen, mit Zahlen 1-6 For i = 2 To 12 Step 2 If .Cells(2, i) "" Then NeuTxt = NeuTxt & "_" & .Cells(1, i - 1) & .Cells(2, i) End If Next i 'Archivpfad laden, "_" Vorspann abschneiden Archiv = .Range("Q5"): NeuTxt = Mid(NeuTxt, 2) End With 'String für neuen Dateinamen bilden DTyp = Mid(Datei, InStrRev(Datei, ".") + 1) 'Endung xls NeuDatei = Left(Datei, InStrRev(Datei, ".") - 1) 'Cut Endung If Notiz "" Then Notiz = "_" & 7 & Notiz 'Zahl 7 setzen '** hier kannst du den neuen Dateinamen beliebig zusammenbasteln NeuDatei = Datum & " " & NeuTxt & Notiz & "." & DTyp 'neuer Dateiname ok = MsgBox(NeuDatei & vbLf & "Neue Datei im Archiv speichern?", vbYesNo) On Error GoTo Fehler 'neue Datei in Archiv speichern If ok = vbYes Then Workbooks(Datei).SaveAs Archiv & NeuDatei Workbooks(NeuDatei).Close savechanges:=False 'Datei schliessen Call Alle_Comboboxen_löschen Exit Sub Fehler: MsgBox NeuDatei & " Fehler beim schliessen" End Sub

Sub Schaltfläche26_Klicken() Dim Datum As Variant, i As Integer, Notiz As String Dim Datei As String, NeuDatei As String, ok As Variant Dim Archiv As String, NeuTxt As String, DTyp As String If Workbooks.Count = 1 Then MsgBox "Keine neue Datei geöffnet", vbInformation: Exit Sub With ThisWorkbook.Worksheets("Tabellen") Datei = Workbooks(2).Name 'göffnete Datei (nicht aktiv!) If Datei = ThisWorkbook.Name Then Datei = Workbooks(1).Name Notiz = ThisWorkbook.Worksheets("Startseite").Range("C9") Datum = Format(.Range("P1"), "dd.mm.yy") 'ComboBoxen Werte in Zeile 1 auslesen, mit Zahlen 1-6 For i = 2 To 12 Step 2 If .Cells(1, i) "" Then NeuTxt = NeuTxt & "_" & .Cells(1, i - 1) & .Cells(1, i) End If Next i 'Archivpfad laden, "_" Vorspann abschneiden Archiv = .Range("Q5"): NeuTxt = Mid(NeuTxt, 2) End With 'String für neuen Dateinamen bilden DTyp = Mid(Datei, InStrRev(Datei, ".") + 1) 'Endung xls NeuDatei = Left(Datei, InStrRev(Datei, ".") - 1) 'Cut Endung If Notiz "" Then Notiz = "_" & 7 & Notiz 'Zahl 7 setzen '** hier kannst du den neuen Dateinamen beliebig zusammenbasteln NeuDatei = Datum & " " & NeuTxt & Notiz & "." & DTyp 'neuer Dateiname ok = MsgBox(NeuDatei & vbLf & "Neue Datei im Archiv speichern?", vbYesNo) On Error GoTo Fehler 'neue Datei in Archiv speichern If ok = vbYes Then Workbooks(Datei).SaveAs Archiv & NeuDatei Workbooks(NeuDatei).Close savechanges:=False 'Datei schliessen Call Alle_Comboboxen_löschen Exit Sub Fehler: MsgBox NeuDatei & " Fehler beim schliessen" End Sub

Sub Ordner_Öffnen() 'File Dialog öffnen Dim strDatei As String, FD As Object Dim Pfad As String, NeuPfad As String If Workbooks.Count > 1 Then MsgBox "Es ist bereits eine neue Datei geöffnet": Exit Sub Set FD = Application.FileDialog(msoFileDialogFilePicker) NeuPfad = Tabelle4.Range("Q3").Value With FD 'File Dialog aus dem Internet (angepasst) .Filters.Clear .Filters.Add "Alle-Dateien", "*.*", 1 .Title = "Eine Datei auswählen" .AllowMultiSelect = False Pfad = Left(NeuPfad, Len(NeuPfad) - 1) .InitialFileName = Pfad 'Öffnen Pfad On Error GoTo Fehler If .Show = True Then strDatei = .SelectedItems(1) Workbooks.Open strDatei ThisWorkbook.Activate Call Alle_CommanButton_einblenden '** OLEObjects klappt bei mir nicht (XP ?) Tabelle3.DrawingObjects("Button 26").Enabled = True End If End With Exit Sub Fehler: MsgBox strDatei & " Öffnen Fehler!" End Sub

Hallo Uws
Den Code in der Tabelle Startseite hatte ich geaendert, das war offenbar ein Fehler.
Tausche ihn bitte gegen diesen wiederhergestellten Code aus, und teste es damit.
Für das löschen der Datei im Ordner neu schicke ich dir noch eine Aenderung.
mfg Piet

Option Explicit 'Startseite neu
Dim i As Integer


Private Sub ComboBox1_Change()
Call Speichern_aktivieren  'Button aktivieren!!
With Tabelle4.ListObjects("Tabelle2").DataBodyRange
For i = 1 To .Rows.Count
If .Cells(i, 1) = ComboBox1 Then
CommandButton1.Visible = False
Exit Sub
Else
CommandButton1.Visible = True
End If
Next i
End With
End Sub


Private Sub ComboBox2_Change()
Call Speichern_aktivieren  'Button aktivieren!!
With Tabelle4.ListObjects("Tabelle3").DataBodyRange
For i = 1 To .Rows.Count
If .Cells(i, 1) = ComboBox2 Then
CommandButton2.Visible = False
Exit Sub
Else
CommandButton2.Visible = True
End If
Next i
End With
End Sub


Private Sub ComboBox3_Change()
Call Speichern_aktivieren  'Button aktivieren!!
With Tabelle4.ListObjects("Tabelle4").DataBodyRange
For i = 1 To .Rows.Count
If .Cells(i, 1) = ComboBox3 Then
CommandButton3.Visible = False
Exit Sub
Else
CommandButton3.Visible = True
End If
Next i
End With
End Sub


Private Sub ComboBox4_Change()
Call Speichern_aktivieren  'Button aktivieren!!
With Tabelle4.ListObjects("Tabelle5").DataBodyRange
For i = 1 To .Rows.Count
If .Cells(i, 1) = ComboBox4 Then
CommandButton4.Visible = False
Exit Sub
Else
CommandButton4.Visible = True
End If
Next i
End With
End Sub


Private Sub ComboBox5_Change()
Call Speichern_aktivieren  'Button aktivieren!!
With Tabelle4.ListObjects("Tabelle6").DataBodyRange
For i = 1 To .Rows.Count
If .Cells(i, 1) = ComboBox5 Then
CommandButton5.Visible = False
Exit Sub
Else
CommandButton5.Visible = True
End If
Next i
End With
End Sub


Private Sub ComboBox6_Change()
Call Speichern_aktivieren  'Button aktivieren!!
With Tabelle4.ListObjects("Tabelle7").DataBodyRange
For i = 1 To .Rows.Count
If .Cells(i, 1) = ComboBox6 Then
CommandButton6.Visible = False
Exit Sub
Else
CommandButton6.Visible = True
End If
Next i
End With
End Sub


Private Sub CommandButton1_Click()
Dim i&, j&, iZeile&, arrList, arrTemp
With Tabelle4.ListObjects("Tabelle2").DataBodyRange
iZeile = .Rows.Count + 1
.Cells(iZeile, 1) = ComboBox1
End With
With Tabelle4.ListObjects("Tabelle2").DataBodyRange
arrList = .Value
For i = 1 To iZeile - 1
For j = i + 1 To iZeile
If arrList(i, 1) > arrList(j, 1) Then
arrTemp = arrList(j, 1)
arrList(j, 1) = arrList(i, 1)
arrList(i, 1) = arrTemp
End If
Next j
Next i
.Value = arrList
End With
Call Alle_Comboboxen_löschen
End Sub


Private Sub CommandButton2_Click()
Dim i&, j&, iZeile&, arrList, arrTemp
With Tabelle4.ListObjects("Tabelle3").DataBodyRange
iZeile = .Rows.Count + 1
.Cells(iZeile, 1) = ComboBox2
End With
With Tabelle4.ListObjects("Tabelle3").DataBodyRange
arrList = .Value
For i = 1 To iZeile - 1
For j = i + 1 To iZeile
If arrList(i, 1) > arrList(j, 1) Then
arrTemp = arrList(j, 1)
arrList(j, 1) = arrList(i, 1)
arrList(i, 1) = arrTemp
End If
Next j
Next i
.Value = arrList
End With
Call Alle_Comboboxen_löschen
End Sub


Private Sub CommandButton3_Click()
Dim i&, j&, iZeile&, arrList, arrTemp
With Tabelle4.ListObjects("Tabelle4").DataBodyRange
iZeile = .Rows.Count + 1
.Cells(iZeile, 1) = ComboBox3
End With
With Tabelle4.ListObjects("Tabelle4").DataBodyRange
arrList = .Value
For i = 1 To iZeile - 1
For j = i + 1 To iZeile
If arrList(i, 1) > arrList(j, 1) Then
arrTemp = arrList(j, 1)
arrList(j, 1) = arrList(i, 1)
arrList(i, 1) = arrTemp
End If
Next j
Next i
.Value = arrList
End With
Call Alle_Comboboxen_löschen
End Sub


Private Sub CommandButton4_Click()
Dim i&, j&, iZeile&, arrList, arrTemp
With Tabelle4.ListObjects("Tabelle5").DataBodyRange
iZeile = .Rows.Count + 1
.Cells(iZeile, 1) = ComboBox4
End With
With Tabelle4.ListObjects("Tabelle5").DataBodyRange
arrList = .Value
For i = 1 To iZeile - 1
For j = i + 1 To iZeile
If arrList(i, 1) > arrList(j, 1) Then
arrTemp = arrList(j, 1)
arrList(j, 1) = arrList(i, 1)
arrList(i, 1) = arrTemp
End If
Next j
Next i
.Value = arrList
End With
Call Alle_Comboboxen_löschen
End Sub


Private Sub CommandButton5_Click()
Dim i&, j&, iZeile&, arrList, arrTemp
With Tabelle4.ListObjects("Tabelle6").DataBodyRange
iZeile = .Rows.Count + 1
.Cells(iZeile, 1) = ComboBox5
End With
With Tabelle4.ListObjects("Tabelle6").DataBodyRange
arrList = .Value
For i = 1 To iZeile - 1
For j = i + 1 To iZeile
If arrList(i, 1) > arrList(j, 1) Then
arrTemp = arrList(j, 1)
arrList(j, 1) = arrList(i, 1)
arrList(i, 1) = arrTemp
End If
Next j
Next i
.Value = arrList
End With
Call Alle_Comboboxen_löschen
End Sub


Private Sub CommandButton6_Click()
Dim i&, j&, iZeile&, arrList, arrTemp
With Tabelle4.ListObjects("Tabelle7").DataBodyRange
iZeile = .Rows.Count + 1
.Cells(iZeile, 1) = ComboBox6
End With
With Tabelle4.ListObjects("Tabelle7").DataBodyRange
arrList = .Value
For i = 1 To iZeile - 1
For j = i + 1 To iZeile
If arrList(i, 1) > arrList(j, 1) Then
arrTemp = arrList(j, 1)
arrList(j, 1) = arrList(i, 1)
arrList(i, 1) = arrTemp
End If
Next j
Next i
.Value = arrList
End With
Call Alle_Comboboxen_löschen
End Sub

Sub Schaltfläche26_Klicken() Dim Datum As Variant, i As Integer, Notiz As String Dim Datei As String, NeuDatei As String, ok As Variant Dim Archiv As String, NeuTxt As String, DTyp As String If Workbooks.Count = 1 Then MsgBox "Keine neue Datei geöffnet", vbInformation: Exit Sub With ThisWorkbook.Worksheets("Tabellen") Datei = Workbooks(2).Name 'göffnete Datei (nicht aktiv!) If Datei = ThisWorkbook.Name Then Datei = Workbooks(1).Name Notiz = ThisWorkbook.Worksheets("Startseite").Range("C9") Datum = Format(.Range("P1"), "dd.mm.yy") 'ComboBoxen Werte in Zeile 1 auslesen, mit Zahlen 1-6 For i = 2 To 12 Step 2 If .Cells(1, i) "" Then NeuTxt = NeuTxt & "_" & .Cells(1, i - 1) & .Cells(1, i) End If Next i 'Archivpfad laden, "_" Vorspann abschneiden Archiv = .Range("Q5"): NeuTxt = Mid(NeuTxt, 2) NeuPfad = .Range("Q3") & "\" & Datei 'für Kill End With 'String für neuen Dateinamen bilden DTyp = Mid(Datei, InStrRev(Datei, ".") + 1) 'Endung xls NeuDatei = Left(Datei, InStrRev(Datei, ".") - 1) 'Cut Endung If Notiz "" Then Notiz = "_" & 7 & Notiz 'Zahl 7 setzen '** hier kannst du den neuen Dateinamen beliebig zusammenbasteln NeuDatei = Datum & " " & NeuTxt & Notiz & "." & DTyp 'neuer Dateiname ok = MsgBox(NeuDatei & vbLf & "Neue Datei im Archiv speichern?", vbYesNo) On Error GoTo Fehler 'neue Datei in Archiv speichern If ok = vbYes Then Workbooks(Datei).SaveAs Archiv & NeuDatei Workbooks(NeuDatei).Close savechanges:=False 'Datei schliessen Kill NeuPfad 'Datei in Ordner neu löschen Call Alle_Comboboxen_löschen Exit Sub Fehler: MsgBox NeuDatei & " Fehler beim schliessen" End Sub

Beliebteste Forumthreads (12 Monate)

Geöffnete Datei schließen, umbenennen un

18
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Geöffnete Datei schließen, umbenennen un

18 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

18
Beiträge zum Forumthread

Beiträge zu diesem Forumthread