Forumbeitrag
Excel-Version des Fragestellers:
2019
Erfahrungslevel des Fragestellers:
Excel gut - VBA bescheiden
Hi
ja, sinnvollerweise würde man alle Dateien in einen Ordner packen, das macht es einfacher, aber es ginge auch anders.
hier mal drei Makros die das Beispielhaft ausführen
Datei_leeren leert alle Zellen, die gelb sind
Kunde_einlesen fordert dich auf, eine Kundendatei zu wählen. Dann wird diese geöffnet und die Inhalte werden in deine Arbeitsdatei übernommen
Kunde_Speichern erstellt jetzt die eigentliche Kundendatei. Hierbei werden alle gelben Zellen in eine Exceldatei geschrieben, in Spalte A kommt Blatt und Zelle, in Spalte B kommt der Inhalt. Gespeichert wird dann im selben Verzeichnis wie die Arbeitsdatei unter dem Namen aus Übersicht M1
die Kundendatei enthält dann wirklich nur die Daten in einer ganz einfachen Form, zum Einlesen in die Arbeitsdatei über das Makro
die Arbeitsdatei kann schreibgeschützt sein (und sollte das auch).
Änderungen kannst du in der Arbeitsdatei an den Makros beliebig hinzufügen.
das einzige, was du nicht ändern darfst, ist die Position der gelben Zellen, denn sonst funktioniert das Einlesen eventuell nicht mehr.
auch die Blätter darfst du nicht löschen oder umbenennen.
Was du machen kannst, ist neue Blätter hinzufügen und auch neue Zellen gelb färben.
Option Explicit
Const FarbeDatenZelle As Long = 65535
Sub Kunde_Einlesen()
Dim datei As String
Dim arr
Dim i As Long
datei = Application.GetOpenFilename(, , "Kunde auswählen")
If Not datei Like "*.xlsx" Then Exit Sub
Call Datei_Leeren
Zeit_Einlesen = Now
With Workbooks.Open(datei, ReadOnly:=True)
arr = Sheets(1).Cells(2, 1).CurrentRegion.Value
.Close False
End With
For i = 1 To UBound(arr, 2)
If arr(i, 1) <> "" Then
Range(arr(i, 1)).Value = arr(i, 2)
End If
Next
End Sub
Sub Kunde_Speichern()
Dim sh As Worksheet
Dim zelle As Range
Dim wb As Workbook
Set wb = Workbooks.Add(xlWBATWorksheet)
ThisWorkbook.Activate
For Each sh In ThisWorkbook.Worksheets
For Each zelle In sh.UsedRange.Cells
If zelle.Interior.Color = FarbeDatenZelle Then
If zelle.Value <> "" Then
With wb.Sheets(1).Cells(Rows.Count, 1).End(xlUp)
.Offset(1, 0).Value = sh.Name & "!" & zelle.Address(0, 0)
.Offset(1, 1).Value = zelle.Value
End With
End If
End If
Next
Next
Application.DisplayAlerts = False
wb.SaveAs ThisWorkbook.Path & "\" & ThisWorkbook.Sheets("Übersicht").Range("M1").Value, xlOpenXMLWorkbook
Application.DisplayAlerts = True
wb.Close False
End Sub
Sub Datei_Leeren()
Dim sh As Worksheet
Dim zelle As Range
Dim Bereich As Range
For Each sh In ThisWorkbook.Worksheets
Set Bereich = Nothing
For Each zelle In sh.UsedRange.Cells
If zelle.Interior.Color = FarbeDatenZelle Then
If Bereich Is Nothing Then
Set Bereich = zelle
Else
Set Bereich = Union(Bereich, zelle)
End If
End If
Next
If Not Bereich Is Nothing Then Bereich.ClearContents
Next
End Sub
Gruß Daniel