Hallo,
eigentlich müsste das doch auch relativ einfach mit Formeln, also ohne VBA gehen. => würde ich mal in Erwägung ziehen.
Was mir direkt auffällt: wenn du die Workbook.SaveAs - Methode benutzt, solltest du immer auch das Fileformat mit angeben:
If SaveDummy <> False Then ActiveWorkbook.SaveAs SaveDummy, fileformat:=-4143 ' für eine *.xls-Datei
oder
If SaveDummy <> False Then ActiveWorkbook.SaveAs SaveDummy, fileformat:=52 ' für eine *.xlsm-Datei
Um das ganze etwas zu vereinfachen und den Programmieraufwand zu verringern würde ich eine Vorlagendatei erstellen, die bereits alle Diagramme fertig formatiert beinhaltet. Dann würde sich nämlich alles auf
=> Vorlagendatei öffnen
=> Datendateien öffnen
=> Daten aus den Datendateien in die Vorlage kopieren
=> Datendateien schließen
=> Vorlage speichern
reduzieren. Das würde ich alles in einem einzigen Makro machen, dann wird es nämlich deutlich einfacher.
In einem if .. then ... else ... end if - Konstrukt wird immer nur der Code zwischen then und else oder der zwischen else und end if ausgeführt:
sub IfBeispielAusprobieren()
if second(time) mod 2 = 0 then
msgbox "diese Box erscheint, weil die If-Bedingung wahr ist"
else
msgbox "diese Box erscheint, weil die If-Bedingung nicht wahr ist."
end if
end sub
Wenn du obiges Makro ausprobierst, siehst du, dass immer nur eine MsgBox erscheint. Deine Goto-Anweisungen sind also völlig überflüssig.
Der Code könnte um bei deinem Konstrukt zu bleiben in etwa so aussehen:
Sub DatenVergleich()
dim wbDiagramm as workbook
dim wsZiel as worksheet
dim wsQuelle as worksheet
dim wsAufruf as worksheet
'aktuelles Tabellenblatt merken
set wsAufruf = activesheet
'Vorlagendatei öffnen
set wbDiagramm = workbooks.add("C:\pfad\Vorlagendatei.xltx")
set wsziel = wbdiagramm.worksheets(1) 'Tabellenblatt, in das alle Daten kopiert werden
'Raumschallmessung Datei 1
If Range("B13").Value = "" Then
'mach nichts
Else
Workbooks.Open Filename:=wsAufruf.Range("B13") 'Datendatei öffnen
set wsquelle = activeworkbook.worksheets("dB(A)") 'Tabellenblatt in dem die Daten stehen
wsZiel.range("A2:B201").value = wsQuelle.Range("D12:E211") 'Daten Mikrofon 1 kopieren
wsziel.range("C2:C201").value = wsQuelle.Range("J12:J211") 'Daten Mikrofon 2 kopieren
'... 'Daten Mikrofon 3 kopieren
wsQuelle.parent.close savechanges:=false 'Datendatei schließen
End If
'Raumschallmessung Datei 2
If Range("B15").Value = "" Then
'mach nichts
Else
Workbooks.Open Filename:=wsAufruf.Range("B15") 'Datendatei öffnen
set wsquelle = activeworkbook.worksheets("dB(A)") 'Tabellenblatt in dem die Daten stehen
wsZiel.range("K2:L201").value = wsQuelle.Range("D12:E211") 'Daten Mikrofon 1 kopieren
wsziel.range("M2:M201").value = wsQuelle.Range("J12:J211") 'Daten Mikrofon 2 kopieren
'... 'Daten Mikrofon 3 kopieren
wsQuelle.parent.close savechanges:=false 'Datendatei schließen
End If
'Raumschallmessung Datei 3
If Range("B17").Value = "" Then
'mach nichts
Else
Workbooks.Open Filename:=wsAufruf.Range("B17") 'Datendatei öffnen
set wsquelle = activeworkbook.worksheets("dB(A)") 'Tabellenblatt in dem die Daten stehen
wsZiel.range("U2:V201").value = wsQuelle.Range("D12:E211") 'Daten Mikrofon 1 kopieren
wsziel.range("W2:W201").value = wsQuelle.Range("J12:J211") 'Daten Mikrofon 2 kopieren
'... 'Daten Mikrofon 3 kopieren
wsQuelle.parent.close savechanges:=false 'Datendatei schließen
End If
'Raumschallmessung Datei 4
If Range("B19").Value = "" Then
'mach nichts
Else
Workbooks.Open Filename:=wsAufruf.Range("B19") 'Datendatei öffnen
set wsquelle = activeworkbook.worksheets("dB(A)") 'Tabellenblatt in dem die Daten stehen
wsZiel.range("AE2:AF201").value = wsQuelle.Range("D12:E211") 'Daten Mikrofon 1 kopieren
wsziel.range("AG2:AG201").value = wsQuelle.Range("J12:J211") 'Daten Mikrofon 2 kopieren
'... 'Daten Mikrofon 3 kopieren
wsQuelle.parent.close savechanges:=false 'Datendatei schließen
End If
'Raumschallmessung Datei 5
If Range("B21").Value = "" Then
'mach nichts
Else
Workbooks.Open Filename:=wsAufruf.Range("B21") 'Datendatei öffnen
set wsquelle = activeworkbook.worksheets("dB(A)") 'Tabellenblatt in dem die Daten stehen
wsZiel.range("AO:AP201").value = wsQuelle.Range("D12:E211") 'Daten Mikrofon 1 kopieren
wsziel.range("AQ2:AQ201").value = wsQuelle.Range("J12:J211") 'Daten Mikrofon 2 kopieren
'... 'Daten Mikrofon 3 kopieren
wsQuelle.parent.close savechanges:=false 'Datendatei schließen
End If
'hier könnte jetzt das Speichern der neuen Datei kommen:
'wbDiagramm.SaveAs "c:\....\...\...xls", fileformat:=-4143
End Sub
Der Code ist nicht getestet. Selbstverständlich muss jeder Bereich angepasst werden und auch die Dateipfade / Dateinamen.
|