Daten befüllen Makro

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Private Sub kopierenAlleABC() KopierenABC1Kp KopierenABC2Kp End Sub Private Sub KopierenABC1Kp() Windows("Entwurf DTK 1.Kp.xlsm").Activate Dim ZeileABC, SpalteABC, ZelleABC, StartABC, EndeABC As String Dim KZeileABC, KSpalteABC, KZelleABC SpalteABC = "B" SpalteEndeABC = "D" ZeileABC = 14 StartABC = SpalteABC & ZeileABC ZelleABC = SpalteABC & ZeileABC Test = True: Zähler = 0 ' Variablen initialisieren. Do ' Äußere Schleife. Do While Zähler

Sub kopieren(BlattVon As Worksheet, BlattNach As Worksheet) Dim maxZeile&, maxZeile2&, s& Const Spalten = "BEHK" Const überschriftenzeile = 13 For s = 1 To Len(Spalten) maxZeile = BlattVon.Range(Mid(Spalten, s, 1) & BlattVon.Rows.Count).End(xlUp).Row If maxZeile > überschriftenzeile Then maxZeile2 = BlattNach.Range(Mid(Spalten, s, 1) & _ BlattNach.Rows.Count).End(xlUp).Row BlattVon.Range(Mid(Spalten, s, 1) & überschriftenzeile + 1). _ Resize(maxZeile - überschriftenzeile, 3).Copy BlattNach.Range(Mid(Spalten, s, 1) & maxZeile2 + 1).PasteSpecial xlPasteValues End If Next End Sub

Ich danke recht herzlich Michael,
ja das mit dem Arbeitgeber ist immer ein Thema für sich...
Mal schauen, ob wir damit jetzt mehr erreichen können.
Naja wo was hin soll?
also angenommen in der 1.Kompanie existiert diese Übersichtsdatei mit allen Nebenfunktionen gefüllt mit Daten, dann soll in die Übersichtsdatei des Bataillons, diese Daten 1:1 sozusagen übernommen werden.
In Bezug auf Abc-Abwehr würde das heißen, ich habe in der 1.Kompanie alle Daten von den jeweiligen Dienstgraden in den dafür vorgesehenen Zeilen, startend ab zeile 14. diese sollen dann in die Bataillonsübersicht 1:1 kopiert werden auch ab Zeile 14. Anschließend soll dies dann für alle anderen Nebentätigkeiten identisch passieren und dann darunter die nächste Kompanie, so dass man dann am Ende eine große Übersicht hat, wo alle Kompanien aufgeführt sind, wer welche Nebenfunktion bekleidet. Musterexemplarisch haben wir hier nur die Struktur von der Abc-Abwehr drin. Die anderen Registerblätter haben dann aber oben den gleichen Kopf nur mit einer anderen Nebenfunktion.
Hier mal zur Verdeutlichung die Bataillonsüberischtsdatei und die 1. und 2. Kompanie
https://www.herber.de/bbs/user/103257.xlsm
https://www.herber.de/bbs/user/103258.xlsm
https://www.herber.de/bbs/user/103259.xlsm
Insgesamt gibt es dann nachher 8 Kompanie-Datei die alle Quelle sind und 1 Bataillonsübersicht, wo die Daten dann hineinübertragen werden sollen, für die Gesamtübersicht
LG
Bernd

Hallo Bernd,
das sind ja im Prinzip genau die drei Datein, die ich Dir als ZIP hochgeladen habe, nur daß ich in den beiden Quelldatein die Zeilen 1-13 und die Formatierung leer gelassen habe.
Wie Du oben siehst, vergibt die Forumssoftware immer eigene Dateinamen, d.h. wenn man mit mehreren Datein hantiert, bei denen es auf die Namen ankommt, sollte man sie zippen.
Hat der Button auf "Bedienung" so funktioniert, wie er sollte?
Dann mußt Du hier eigentlich nur die zu importierenden Dateinamen eintragen (C4 runterwärts), E1 und E2 eintragen, welche Zellen in Spalte C ausgewertet werden sollen, und das Ding funktioniert, wie es ist.
Die Makros befinden sich im neu angelegten Modul "Michael":
- Sub Kopieren ist unverändert, heißt aber jetzt MichaelKopieren (weil Du in einem anderen Modul bereits den Namen Kopieren benutzt hast),
- und in das

Sub kopierenExterneDatei()
Dim sFile As String, sPath As String
Dim Quelle As Workbook, Ziel As Workbook
Dim Blatt As Worksheet, ZielBlatt As Worksheet
Dim von&, bis&, i&
Dim gehtnicht As Boolean
von = Sheets("Bedienung").Range("E1")
bis = Sheets("Bedienung").Range("E2")
Set Ziel = ActiveWorkbook
Application.ScreenUpdating = False
For i = von To bis
gehtnicht = False
sPath = Ziel.Sheets("Bedienung").Range("C" & i)
sFile = Mid(sPath, InStrRev(sPath, "\") + 1)
If WkbExists(sFile) = False Then
If Dir(sPath) = "" Then
'         MsgBox "Datei " & sPath & " wurde nicht gefunden!"
Ziel.Sheets("Bedienung").Range("D" & i) = "#n.v."
gehtnicht = True
Else
Workbooks.Open sPath
End If
Else
Workbooks(sFile).Activate
End If
If Not gehtnicht Then
Set Quelle = ActiveWorkbook
For Each Blatt In Quelle.Sheets
' hier müßte noch ne Fehlerroutine rein... *******
' falls ein Blatt nicht in *beiden* Datein vorh. ist
' UND man kann Blätter ausschließen, z.B.:
If Blatt.Name  "Bedienung" And Blatt.Name  "Übersicht" _
And Blatt.Name  "Tabelle1" Then
On Error Resume Next
Set ZielBlatt = Ziel.Sheets(Blatt.Name)
If Err.Number  0 Then
MsgBox Blatt.Name & " in Zieldatei nicht vorhanden."
Else
Call MichaelKopieren(Blatt, ZielBlatt)
End If
On Error GoTo 0
End If
Next
Ziel.Sheets("Bedienung").Range("D" & i) = "o.k."
Quelle.Close
End If
Next
Application.ScreenUpdating = True
End Sub

habe ich ein Errorhandling eingebaut und die Blätter "Bedienung", "Übersicht" und "Tabelle1" von der Bearbeitung ausgeschlossen.
Somit werden ALLE Tabellenblätter mit Daten (sofern vorhanden) importiert, sowohl aus den beiden bereits in der ersten ZIP enthaltenen Quelldatein als auch der von Dir hochgeladenen 103259.xlsm
Die Datein: https://www.herber.de/bbs/user/103293.zip
Schöne Grüße,
Michael

Beliebteste Forumthreads (12 Monate)

7 Beiträge zum Forumthread Beiträge zu diesem Forumthread

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

7
Beiträge zum Forumthread

Beiträge zu diesem Forumthread