Duplikate anhand Liste und bereinigen
19.10.2020 10:49:24
Blume
ich habe vor einiger Zeit ein herausragendes Makro bekommen:
Sub MA_Dateien_speichern()
Dim strName As String, varOrdner, varDateixlsm, varDateixlsx
Dim zeile As Long
Dim wkb As Workbook
Dim wkbMA As Workbook
Set wkb = ActiveWorkbook
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Bitte Ordner für zu erstellende Dateien auswählen/erstellen"
If .Show = -1 Then
varOrdner = .SelectedItems(1)
Else
Exit Sub
End If
End With
With wkb.Worksheets(8)
'Kürzel-Liste abarbeiten
For zeile = 5 To .Cells(.Rows.Count, 6).End(xlUp).Row 'startzeile ggf. anpassen.
strName = .Cells(zeile, 6).Text
varDateixlsm = varOrdner & Application.PathSeparator & strName & ".xlsm"
varDateixlsx = varOrdner & Application.PathSeparator & strName & ".xlsx"
If wkb.FileFormat = 52 Then 'xlOpenXMLTemplateMacroEnabled
'Datei ist Datei mit Makros
wkb.SaveCopyAs varDateixlsm
Set wkbMA = Application.Workbooks.Open(varDateixlsm)
With wkbMA.Worksheets(1)
.Range("D2").Value = strName
.Calculate
.Cells.Locked = True
.Protect Password:="Test"
End With
Application.DisplayAlerts = False
wkbMA.SaveAs varDateixlsx, FileFormat:=51
Application.DisplayAlerts = True
wkbMA.Close savechanges:=True
VBA.Kill varDateixlsm
Else
'Datei hat keine Makros
wkb.SaveCopyAs varDateixlsx
Set wkbMA = Application.Workbooks.Open(varDateixlsx)
With wkbMA.Worksheets(1)
.Range("D2").Value = strName
.Calculate
.Cells.Locked = True
.Protect Password:="Test"
End With
wkbMA.Save
wkbMA.Close savechanges:=True
End If
Next
End With
End Sub
Ist es möglich, dass man die Dateien wenn Sie nach den Kürzeln gesplittet bzw. dupliziert werden auch noch dazu in dem Worksheet "Protokoll" alle anderen Daten gelöscht werden, bis auf die Zeilen, wo Spalte C das gleiche Kürzel enthält wie in Worksheet "EIngabe" D". Damit würde man in den einzelnen Dateien viele sinnlose Zeilen sparen, was es für die Weiterverarbeitung vereinfachen würde. Ist so etwas möglich?