Daten aus anderer Datei auslesen
16.02.2022 13:01:19
Gasius
ich wurde mit der Lösung einer Aufgabe betreut und versuche dies über VBA zu lösen.
Folgender Fall:
Ich habe ein Workbook "Artikel", in dessen Worksheet "EU" unterschiedliche Artikel nach Produktgruppe und mit vielen weiteren Daten aufgelistet sind.
Für die einzelnen Produktgruppen möchte ich ein neues Sheet erstellen, nur relevante Daten kopieren und in das bestimmte Sheet einfügen. Das für alle Gruppen. Klappt auch soweit.
Nun habe ich vier weitere offene Spalten in jedem Sheet deren Daten in einem anderen Workbook "Auszug" liegen. Das Workbook soll geöffnet werden und anhand der "Artikelnummer" soll das "Kennzeichen 1", "Kennzeichen 2" "Kennzeichen 3" & "Kennzeichen 4" kopiert und in das Workbook "Artikel" eingefügt werden. Anschließend soll jedes Sheet einzeln abgespeichert werden.
Das Workbook bekomme ich noch geöffnet, allerdings weiß ich nicht wie ich weiter vorgehen soll. Da fehlen mir dann die Kenntnisse dafür Kann mir da jemand behilflich sein? Wäre sehr dankbar dafür! Vielen dank schonmal im Voraus
Anbei mal mein Skript bis da hin:
Option Explicit
Dim sheet As Object
Dim sheetname As String
Dim wks As Worksheet
Dim wksDaten As Worksheet
Dim wkbDaten As Workbook
Dim cell As Range
Dim c As Double 'Zeilenzähler
Dim rng As Range
Dim bolFlg As Boolean 'Wahrheitsbit
Sub Aufteilungen()
sheetname = "Reifen" 'Blattname festlegen
'---- Prüfen ob Blatt bereits vorhanden'
For Each sheet In Sheets
If sheet.Name = sheetname Then bolFlg = True
Next sheet
'---- Blatt einfügen wenn noch nicht vorhanden
If bolFlg = False Then
With ThisWorkbook
Worksheets.Add after:=Worksheets("EU")
ActiveSheet.Name = sheetname
With ActiveSheet
.Range("A1:I1").Value = Array("Artikelnummer", "Serie", "Produktgruppe", "Produkttyp", "Artikelbezeichnung", "Kennzeichen 1", "Kennzeichen 2", "Kennzeichen 3", "Kennzeichen 4") 'Überschriften einfügen
End With
End With
End If
'---- Werte ausschneiden und in Blatt einfügen
Set rng = Worksheets("EU").Range("F:F")
For Each cell In rng
c = cell.Row 'Reihe der Zelle
If cell.Value = "WCs" Or cell.Value = "WC-Sets" Then
Worksheets("EU").Range("K" & c).Cut 'Ausschneiden von Artikelnummer
Worksheets("Reifen").Range("A" & c).Insert
Worksheets("EU").Range("C" & c).Cut 'Ausschneiden von Serie
Worksheets("Reifen").Range("B" & c).Insert
Worksheets("EU").Range("F" & c, "H" & c).Cut 'Ausschneiden von Produktgruppe, Produkttyp und Artikelbezeichnung
Worksheets("Reifen").Range("C" & c, "E" & c).Insert
End If
Next
'----- Leere Zeilen löschen
With ActiveSheet.UsedRange
.AutoFilter Field:=2, Criteria1:="="
.Offset(1, 0).EntireRow.Delete '--- das Offset verhindert das Löschen der Überschrift
.AutoFilter
End With
'------ Türen
sheetname = "Türen" 'Blattname festlegen
'---- Prüfen ob Blatt bereits vorhanden'
For Each sheet In Sheets
If sheet.Name = sheetname Then bolFlg = True
Next sheet
'---- Blatt einfügen wenn noch nicht vorhanden
If bolFlg = False Then
With ThisWorkbook
Worksheets.Add after:=Worksheets("EU")
ActiveSheet.Name = sheetname
With ActiveSheet
.Range("A1:I1").Value = Array("Artikelnummer", "Serie", "Produktgruppe", "Produkttyp", "Artikelbezeichnung", "Kennzeichen 1", "Kennzeichen 2", "Kennzeichen 3", "Kennzeichen 4") 'Überschriften einfügen
End With
End With
End If
'---- Werte ausschneiden und in Blatt einfügen
Set rng = Worksheets("EU").Range("F:F")
For Each cell In rng
c = cell.Row 'Reihe der Zelle
If cell.Value = "WCs" Or cell.Value = "WC-Sets" Then
Worksheets("EU").Range("K" & c).Cut 'Ausschneiden von Artikelnummer
Worksheets("Türen").Range("A" & c).Insert
Worksheets("EU").Range("C" & c).Cut 'Ausschneiden von Serie
Worksheets("Türen").Range("B" & c).Insert
Worksheets("EU").Range("F" & c, "H" & c).Cut 'Ausschneiden von Produktgruppe, Produkttyp und Artikelbezeichnung
Worksheets("Türen").Range("C" & c, "E" & c).Insert
End If
Next
'----- Leere Zeilen löschen
With ActiveSheet.UsedRange
.AutoFilter Field:=2, Criteria1:="="
.Offset(1, 0).EntireRow.Delete '--- das Offset verhindert das Löschen der Überschrift
.AutoFilter
End With
'-------------------- weitere Produktgruppen nach selbem Schema an dieser Stelle ---------------------------------------------
'--------- EU Worksheet löschen
Application.DisplayAlerts = False
Worksheets("EU").Delete
Application.DisplayAlerts = True
End Sub
'Sub Kennzeichen()
On Error GoTo FEHLER
With Application
.ScreenUpdating = False
.EnableEvents = False
.Calculation = xlCalculationManual
End With
Workbooks.Open "U:\Gasius\Auszug.xlsx"
'End Sub
Gasius