Thema Datum  Von Nutzer Rating
Antwort
01.02.2019 14:08:30 Marcel
NotSolved
01.02.2019 23:18:02 Gast49761
NotSolved
01.02.2019 23:18:11 Gast62861
NotSolved
Blau Diagramme in anderer Mappe, Daten aus anderen Dateien
 01.02.2019 23:18:11 Gast3645
NotSolved
03.02.2019 17:39:59 Gast31186
NotSolved
04.02.2019 00:46:04 Gast58039
NotSolved
05.02.2019 08:43:30 Marcel
NotSolved
05.02.2019 10:18:38 Gast81619
NotSolved
09.02.2019 18:56:13 Marcel
NotSolved
10.02.2019 04:10:28 Ulrich
NotSolved

Ansicht des Beitrags:
Von:
Gast3645		 Datum:
01.02.2019 23:18:11		 Views:
622		 Rating:
     
Antwort:
  Ja
Thema:
Diagramme in anderer Mappe, Daten aus anderen Dateien

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:

?
1
If SaveDummy <> False Then ActiveWorkbook.SaveAs SaveDummy, fileformat:=-4143   ' für eine *.xls-Datei

oder

?
1
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:

?
1
2
3
4
5
6
7
8
9
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:

?
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
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.

 

Ihre Antwort
  • Bitte beschreiben Sie Ihr Problem möglichst ausführlich. (Wichtige Info z.B.: Office Version, Betriebssystem, Wo genau kommen Sie nicht weiter)
  • Bitte helfen Sie ebenfalls wenn Ihnen geholfen werden konnte und markieren Sie Ihre Anfrage als erledigt (Klick auf Häckchen)
  • Bei Crossposting, entsprechende Links auf andere Forenbeiträge beifügen / nachtragen
  • Codeschnipsel am besten über den Code-Button im Text-Editor einfügen
  • Die Angabe der Emailadresse ist freiwillig und wird nur verwendet, um Sie bei Antworten auf Ihren Beitrag zu benachrichtigen
Thema: Name: Email:
WYSIWYG-Editor, ctl00_Content_editor1



  • Bitte beschreiben Sie Ihr Problem möglichst ausführlich. (Wichtige Info z.B.: Office Version, Betriebssystem, Wo genau kommen Sie nicht weiter)
  • Bitte helfen Sie ebenfalls wenn Ihnen geholfen werden konnte und markieren Sie Ihre Anfrage als erledigt (Klick auf Häckchen)
  • Bei Crossposting, entsprechende Links auf andere Forenbeiträge beifügen / nachtragen
  • Codeschnipsel am besten über den Code-Button im Text-Editor einfügen
  • Die Angabe der Emailadresse ist freiwillig und wird nur verwendet, um Sie bei Antworten auf Ihren Beitrag zu benachrichtigen

Thema Datum  Von Nutzer Rating
Antwort
01.02.2019 14:08:30 Marcel
NotSolved
01.02.2019 23:18:02 Gast49761
NotSolved
01.02.2019 23:18:11 Gast62861
NotSolved
Blau Diagramme in anderer Mappe, Daten aus anderen Dateien
 01.02.2019 23:18:11 Gast3645
NotSolved
03.02.2019 17:39:59 Gast31186
NotSolved
04.02.2019 00:46:04 Gast58039
NotSolved
05.02.2019 08:43:30 Marcel
NotSolved
05.02.2019 10:18:38 Gast81619
NotSolved
09.02.2019 18:56:13 Marcel
NotSolved
10.02.2019 04:10:28 Ulrich
NotSolved