Makro kopiert nicht alle Dateien und Zellen
05.12.2014 07:40:25
Selma
ich habe mehrere Probleme mit meinem Code und hoffe hier Tipps zu bekommen. Bin ein Neuling und hangel mich irgendwie durch.
Es geht darum, dass ich mit meinem Code Dateien öffne und dort bestimmte Bereiche herauskopiere und in eine neue Datei einfüge. Das sollte möglichst mit einer Verknüpfung passieren, da sich Daten evtl. ändern könnten und es zu mühsam wäre jedes mal aufs neue die Daten zusammenzuführen. Wie das funktioniert, weiss ich aber nicht. Aber das ist erstmal zurückgestellt.
In erster Linie habe ich das Problem, dass mir in meiner neuen Datei immer mindestens von einer Datei die Daten fehlen. Diese also nicht auftauchen in der zusammengeführten Datei.
Außerdem werden nicht alle Zellen kopiert von den anderen Dateien.(Zieldatei: ab Q11).
Kann mir jemand erklären was ich falsch mache? (ausser dass meine Kopierkünste extrem unelegant sind :) )
Mein offset-Teil klappt z.B. auch gar nicht wie ich will. Kopiert mir Verweise, aber nicht Werte (+ evtl. Verknüpfungen).
Sub Vergleich()
Dim DateiName As Variant
Dim i As Integer
Dim strFileFilter As String
Dim wsTemplate As Worksheet 'Template Tabellenblatt
Dim wsZiel As Worksheet 'Ziel
Dim wbQuelle As Workbook 'Quelle
Dim Spalte As Long
Dim SpalteTemp As Long
'Dim a As Integer
'Dim b As Integer
'Dim c As Integer
'Dim d As Integer
Dim strString As String
Dim rngCell As Range
'Fehlermeldungen, Events und Bildschirmaktualisierung deaktivieren
Application.EnableEvents = False
Application.ScreenUpdating = False
Application.DisplayAlerts = False
'Template Tabellenblatt definieren
Set wsTemplate = ActiveSheet
'Datum und Runde eingeben
datum = InputBox(prompt:="Geben Sie das aktuelle Datum ein!")
If datum = "" Then
MsgBox "Ohne Datum können Sie nicht fortfahren!" & vbCr & "Erstellung wurde abgebrochen! _
_
_
", vbOKOnly, "Abbruch"
Exit Sub
End If
ActiveSheet.Range("A3").Value = datum
runde = InputBox(prompt:="Geben Sie die Runde des Projekts ein")
If runde = "" Then
MsgBox "Ohne Angabe der Runde können Sie nicht fortfahren!" & vbCr & "Erstellung wurde _
_
_
abgebrochen!", vbOKOnly, "Abbruch"
Exit Sub
End If
ActiveSheet.Range("B1").Value = runde
'Dateinamen (mit Pfad)
'über mehrere Ordner realisieren!!
strFileFilter = "ExcelDateien,*.xls;*.xlsx;*.xlsm, Alle Dateien,*.*"
DateiName = Application.GetOpenFilename(strFileFilter, , , , True) 'Dateinamen _
einlesen
If VarType(DateiName) = vbBoolean Then Exit
'Falls auf abbrechen geklickt wurde
'Schleife über alle Dateinamen
Spalte = 3
SpalteTemp = Spalte
For i = 1 To UBound(DateiName)
'Datei öffnen
Set wbQuelle = Workbooks.Open(DateiName(i), ReadOnly:=True, UpdateLinks:=False)
If i = 1 Then
'Tabellenblatt kopieren
wsTemplate.Copy
Set wsZiel = ActiveSheet
Else
'Teamleiter muss an 1.Stelle stehen!!!!
If wbQuelle.Worksheets("Deckblatt").Range("C4").Value = "Teamleiter" Then
SpalteTemp = Spalte
Spalte = 3
End If
End If
'Kopiervorgang.
wsZiel.Cells(8, Spalte).Value = wbQuelle.Worksheets("Deckblatt").Range("C4").Value _
_
_
'Name
wsZiel.Cells(2, 2).Value = wbQuelle.Worksheets("Deckblatt").Range("C2").Value _
_
_
'Projektname
wsZiel.Cells(10, Spalte).Resize(1, 4).Value = wbQuelle.Worksheets("Mannschaft").Range(" _
_
_
C8:F8").Value 'MannschaftVolumen
' Leistung wird kopiert ######################################################################## _
_
_
' kopiert die Verlinkung statt den Werten (brauche beides)
strString = "Leistung"
Set rngCell = ActiveSheet.Columns(2).Find(strString, lookat:=xlWhole, LookIn:=xlValues, _
MatchCase:=True)
If Not rngCell Is Nothing Then
rngCell.Offset(1, 1).Resize(11, 5).Copy Destination:=wsZiel.Cells(355, Spalte)
Else
MsgBox "Leistung von " + wbQuelle.Name + " wurde nicht kopiert"
End If
'** Mannschaft Platzbezeichnung - Versuch unteren Teil zu vereinfachen fehlgeschlagen
' a = 9
' For a = 9 To 45
' b = 3
' For b = 3 To 79
' wsZiel.Cells(a, 1).Value = wbQuelle.Worksheets("Mannschaft").Range(6, b).Value
' If a