Schritt 1
Neue Daten
Durch dieses Makro kann in der Exceldatei DATENBANK1A ein neues Tabellenblatt mit einem Namen erstellt werden (z.B. Artikelnummer 123).
Dann wird mit dieser Makro aus einem Ordner der sich Artikel nennt, eine Exceldatei geöffnet. Man muss in der InputBox z.B. ( Artikelnummer 123) eingeben. Die Inhalte aus dem Tabellenblatt (ART-Beschreibung) dieser Exceldatei werden kopiert und zwar der Bereich von A1 bis X und anschließend in das neu erstellte Tabellenblatt der Exceldatie DATENBANK1A hineinkopiert.
Sub DATENBANK1A()
Dim neuname As String
Dim ABT As String
Dim wb1 As Workbook
Dim lz As Long
Dim anw
Dim i As Long
'Schritt 1 Neue Daten
'Bildschirmaktualisierung ausschalten:
Application.ScreenUpdating = False
Set wb1 = ActiveWorkbook
inputname:
neuname = InputBox("Das neue Tabellenblatt benennen")
If neuname = "" Then
anw = MsgBox("Invalid name! Try again?", 20, "Error")
If anw = vbYes Then
GoTo inputname
Else
Exit Sub
End If
End If
For i = 1 To wb1.Worksheets.Count
If neuname = Worksheets(i).Name Then
anw = MsgBox("The name " & neuname & " already exists in this workbook! Try again?", 20, "Error")
If anw = vbYes Then
GoTo inputname
Else
Exit Sub
End If
End If
Next i
again:
Artikelnummer = InputBox(" Bitte die Artikelnummer eingeben")
If Artikelnummer = "" Then
anw = MsgBox("Invalid name! Try again?", 20, "Error")
If anw = vbYes Then
GoTo again
Else
Exit Sub
End If
End If
If Dir("C:\Users\Artikel\" & Artikelnummer & ".xls") = "" Then
anw = MsgBox("The file " & Artikelnummer & ".xls doesn't exist! Try again?", 20, "Error")
If anw = vbYes Then
GoTo again
Else
Exit Sub
End If
End If
Sheets.Add After:=ActiveWorkbook.Sheets(ActiveWorkbook.Sheets.Count)
ActiveSheet.Name = neuname
Workbooks.Open Filename:="C:\Users\Artikel\" & Artikelnummer & ".xls"
With Workbooks(Artikelnummer & ".xls")
lz = .Worksheets("ART-Beschreibung").Cells(Rows.Count, 2).End(xlUp).Row
.Worksheets("ART-Beschreibung").Range("A1:X" & lz).copy Destination:=wb1.Worksheets(neuname).Range("A1")
.Close (False)
End With
'Bildschirmaktualisierung einschalten:
Application.ScreenUpdating = True
End Sub
…………………………………………….
Schritt 2
Neue Daten speichern:
Mit dieser Makro werden alle Inhalte aus den neu erstellten Tabellenblätter (mit dem Namen Artikelnummer…) der Exceldatei DATENBANK1A kopiert und in das Tabellenblatt welches sich DATA nennt hineinkopiert. Hier wäre es schon sehr gut wenn es möglich wäre die beiden Makros nacheinander abspielen zu können. Das bedeutet man aktiviert einen Button und es laufen die beiden Makros nacheinander ab.
Sub DATENBANK1A ()
Dim ws As Worksheet
' Schritt 2 Neue Daten speichern
Application.ScreenUpdating = False
'Kopiert aus der Artikelnummer Datei den kompletten Bereich von A bis X in das Tabellenblatt Database der Exceldatei MPD DATENBANK1A Finale
Set Quelltab = ActiveWorkbook.Worksheets("DATA")
Bereich = "A1:X" & Quelltab.Cells(Rows.Count, 1).End(xlUp).Row
Quelltab.Range(Bereich).ClearContents
'Alle Tabellenblätter die mit Artikelnummer beginnen werden kopiert und zwar der Bereich A bis X
For Each ws In ActiveWorkbook.Worksheets
If Left(ws.Name, 14) = "Artikelnummer" Then
With Worksheets(ws.Name)
.Range("A3:X" & .Cells(Rows.Count, 1).End(xlUp).Row).copy
End With
With Worksheets("DATA")
.Range("A" & .Cells(Rows.Count, 1).End(xlUp).Row).PasteSpecial Paste:=xlPasteValuesAndNumberFormats
End With
End If
Next ws
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub
[*]
[sup]
*Threadedit* 02.10.2015, 14:03:22
Admininfo: Führe Threads bitte nicht fort, indem du weitere eröffnest, und vermeide Mehrfachanfragen! Siehe dazu unser FAQ 2, #3 - wie man einen Thread eröffnet[/sup]