Hallo Mo,
danke dir das hat wunderbar geklappt mit den ersten beiden Makros.Hier habe ich das letzte mal eine bitte.
Diese beiden Makros möchte ich gerne nacheinader abspielen.
Sub DATENBANK()
Dim anw
Dim Pfad As String
Dim Datei As String
Dim i As Long
Dim shExists As Boolean
Dim lz As Long
Dim Ziel As String
Dim iZiel As String
Dim wbk As Workbook
'STEP 5 Transfer the Data into an ANNEX
'Bildschirmaktualisierung ausschalten:
Application.ScreenUpdating = False
'Pfad anpassen
Pfad = "C:\Users\.........'
inputname:
iZiel = InputBox("Open up the Data to transfer the Justifications", "Input Filename", iZiel)
If iZiel = "" Then
anw = MsgBox("Invalid name! Try again?", 20, "Error")
If anw = vbYes Then
GoTo inputname
Else
Exit Sub
End If
End If
'Endung ggf. anpassen
Ziel = iZiel & ".xls"
Datei = Pfad & Ziel
If Dir(Datei) = "" Then
anw = MsgBox("The file " & Ziel & " doesn't exist! Try again?", 20, "Error")
If anw = vbYes Then
GoTo inputname
Else
Exit Sub
End If
End If
'Zieldatei öffnen
Workbooks.Open Filename:=Datei
Set wkb = Workbooks.Open(Filename:=Datei)
'Prüfen ob Tabelle mit Namen "Artikelnr" im geöffneten Workbook existiert
For i = 1 To wkb.Worksheets.Count
If wkb.Worksheets(i).Name = "Tasks" Then shExists = True
Next i
'Falls nein, dann Meldung und Abbruch
If shExists = False Then
MsgBox "The Worksheet Tasks doesn't exit in the Workbook named " & wkb.Name & "! Abort!", 16, "Error"
Exit Sub
End If
ThisWorkbook.Sheets("Dashboard").Range("H6:H15").copy With wkb
.Worksheets("Tasks").Range(Cells(IndexPos - 11 + 3, 15), Cells(IndexPos - 1 + 3, 15)).PasteSpecial Paste:=xlPasteValues
.Close (True) End With
Application.CutCopyMode = False 'Kopierauswahl aufheben
'Bildschirmaktualisierung einschalten:
Application.ScreenUpdating = True
MsgBox "The data was copied", 64, "Copy finished"
End Sub
=>>Genau hier wollte ich gerne, dass wenn ich mehr als 100 Artikel beschreibungen habe die zu kopieren sind, das sich die Makro nicht schließt sonder offen bleibt und ich weitere 10 hinein kopieren kann ohne erneut die Makro wieder aufrufen zu müssen und erneut den Dateinamen in die MsgBox eingeben zu müssen.
Da ich sonst bei beispielsweise bei 500 Artikelbeschreibung 50 mal die Datei eintippen muss. Am Ende könnte mann ja fragen weiter? wenn nicht dann die Datei schließen.
Hier habe ich problem mit dem Global... wenn ich beide Makros abspielen möchte bezogen auf dein Vorschlag mit box1 box2 etc.
Global IndexPos As Long
Global ArrQ As Variant
Sub DATENBANK1SAFinale()
Dim Zaehler1 As Long
Dim Zaehler2 As Long
Dim lzeile As Long
'STEP 4 Tasknumber selction
Worksheets("Dashboard").Range("C6:C15").Clear
lzeile = Worksheets("Source").Cells(Rows.Count, 1).End(xlUp).Row
If IndexPos = 0 Then
With Worksheets("Source")
ArrQ = .Range(.Cells(1, 1), .Cells(lzeile, 1))
End With
IndexPos = 1
End If
If IndexPos > UBound(ArrQ) Then
With Worksheets("Source")
ArrQ = .Range(.Cells(1, 1), .Cells(lzeile, 1))
End With
IndexPos = 1
End If
With Worksheets("Source")
If .Cells(lzeile, 1).Value <> ArrQ(UBound(ArrQ), 1) Then
ArrQ = .Range(.Cells(1, 1), .Cells(lzeile, 1))
IndexPos = 1
End If
End With
For Zaehler1 = IndexPos To IndexPos + 9
If Zaehler1 > UBound(ArrQ) Then Exit For
Zaehler2 = Zaehler2 + 1
Worksheets("Dashboard").Cells(Zaehler2 + 5, 3) = ArrQ(Zaehler1, 1)
Next Zaehler1
IndexPos = IndexPos + Zaehler2
End Sub
Vielen Dank ... Gruß Flo!
