Vorlage übertragen

Hallo Excelexperten
Bräuchte mal eure Hilfe habe schon einen Beitrag zu diesem Thema geschrieben aber der ist etwasblöd beschrieben weiß aber nicht wie man den löschen kann.
Habe eine Vorlage in der ich mir Daten über eine Dropdown liste hole.
Diese soll dann mit einem Button übertragen werden in eine andere Mappe die auf dem Laufwerk liegt und nach Ordnern sortiert ist in den Ordnern befinden sich dann die Zeichnungsnummern.
Also müsste das Makro nach dem Ordner mit der Lacknummer aus der Zelle"D11"z.b.(00707-702) suchen.
Die Ordner liegen auf
"K:\DatenAustausch\Lackieraufträge-Muster\Venjakob PC Programm\Protokoll"
Und dann nach der Zeichnungsnummer Zelle"C5"z.b.(13061-359).Da mehrere Zeichnungsnummern in einem Ordner seien können.
Die Ziel Mappe hat einen Blattschutz "preh"und ist genauso aufgebaut wie die Vorlage nur mit Matrix.
Aus der Vorlage müssten dann alle grau hinterlegten Felder kopiert werden und in die Ziehldatei an selber stelle wieder eingefügt werden ohne das in der Ziehldatei die Formatierungen gelöscht werden(wichtig).
so ich hoffe die Erklärung ist einigermaßen verständlich und ihr könnt mir helfen.
Ist für die Arbeit.
Grüße und einen schönen Tag euch allen
Michael
https://www.herber.de/bbs/user/107535.xlsm

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Hallo Michael,
ein entsprechendes Makro kann wie folgt aussehen.
Gruß
Franz

Sub Übertrag()
' Übertrag Makro
Dim sVwez As String, sUVerz As String, sDatei As String
Dim wkbM As Workbook
Dim wksQ As Worksheet, wksM As Worksheet
Dim Zeile As Long, Spalte As Long
Set wksQ = ActiveSheet
sverz = "K:\DatenAustausch\Lackierauftraege-Muster\Venjakob PC Programm\Protokoll\"
sverz = "C:\Users\Public\Test\Archiv\"
sUVerz = wksQ.Cells(11, 4).Text & "\"
sDatei = Dir(sverz & sUVerz & wksQ.Cells(5, 3).Text & ".xls*")
If sDatei  "" Then
Set wkbM = Application.Workbooks.Open(Filename:=sverz & sUVerz & sDatei)
Set wksM = wkbM.Worksheets(1) 'oder Worksheets("Blattname") wenn in allen Dateien  _
identisch
wksM.Unprotect "preh"
With wksM
Zeile = 3
Spalte = 1 'Spalte A
.Cells(Zeile, Spalte).Value = wksQ.Cells(Zeile, Spalte).Value 'Auftrags-Nr.
Zeile = 8
Spalte = 3 'Spalte C
.Cells(Zeile, Spalte).Value = wksQ.Cells(Zeile, Spalte).Value 'Auftrags-Nr.
Spalte = 7 'Spalte G
.Cells(Zeile, Spalte).Value = wksQ.Cells(Zeile, Spalte).Value 'Auftragsmenge.
'Hilfstoffe
Spalte = 2 'Spalte B
For Zeile = 11 To 14
.Cells(Zeile, Spalte).Value = wksQ.Cells(Zeile, Spalte).Value
Next
Spalte = 4 'Spalte D
For Zeile = 11 To 14
.Cells(Zeile, Spalte).Value = wksQ.Cells(Zeile, Spalte).Value
Next
.Cells(11, 6).Value = wksQ.Cells(11, 6).Value 'Charge
'Daten/Parameter
Spalte = 3 'Spalte C
For Zeile = 16 To 31
.Cells(Zeile, Spalte).Value = wksQ.Cells(Zeile, Spalte).Value
Next
'IR-Modul
Spalte = 8 'Spalte H
For Zeile = 24 To 29
.Cells(Zeile, Spalte).Value = wksQ.Cells(Zeile, Spalte).Value
Next
'UV-Modul
Spalte = 8 'Spalte H
For Zeile = 31 To 34
.Cells(Zeile, Spalte).Value = wksQ.Cells(Zeile, Spalte).Value
Next
'Drehwinkel der Pistolen
Spalte = 2 'Spalte B
For Zeile = 33 To 36
.Cells(Zeile, Spalte).Value = wksQ.Cells(Zeile, Spalte).Value
Next
Spalte = 4 'Spalte D
For Zeile = 33 To 36
.Cells(Zeile, Spalte).Value = wksQ.Cells(Zeile, Spalte).Value
Next
'Co² Reinigung
Spalte = 3 'Spalte C
For Zeile = 38 To 40
.Cells(Zeile, Spalte).Value = wksQ.Cells(Zeile, Spalte).Value
Next
'PowerPuck
For Zeile = 37 To 40
For Spalte = 7 To 8 'Spalten G:H
.Cells(Zeile, Spalte).Value = wksQ.Cells(Zeile, Spalte).Value
Next
Next
'Farbangaben
For Zeile = 43 To 49
For Spalte = 3 To 3 'Spalte C
.Cells(Zeile, Spalte).Value = wksQ.Cells(Zeile, Spalte).Value
Next
Next
'Besondere Hinweise
Zeile = 51
Spalte = 1 'Spalte A
.Cells(Zeile, Spalte).Value = wksQ.Cells(Zeile, Spalte).Value 'Auftrags-Nr.
Zeile = 52
.Cells(Zeile, Spalte).Value = wksQ.Cells(Zeile, Spalte).Value 'Auftrags-Nr.
'Datum
Zeile = 53
Spalte = 2 'Spalte B
.Cells(Zeile, Spalte).Value = wksQ.Cells(Zeile, Spalte).Value 'Auftrags-Nr.
'Unterschrift
Spalte = 6 'Spalte F
.Cells(Zeile, Spalte).Value = wksQ.Cells(Zeile, Spalte).Value 'Auftrags-Nr.
.Protect "preh"
'            wkbM.Close savechanges:=True
End With
Else
MsgBox "Datei " & vbLf & "...\" & sUVerz & wksQ.Range("C5").Text & ".xls*" & vbLf _
& "nicht gefunden!."
End If
End Sub

Beliebteste Forumthreads (12 Monate)

8 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

8
Beiträge zum Forumthread

Beiträge zu diesem Forumthread