Makro zur Tabellenverknüpfung 2
16.01.2019 10:22:24
Fabian
vor kurzen hat man mir mit folgendem Makro (danke nochmal an UweD) weitergeholfen. Mit diesem wird automatisch eine Excel Datei (Jahresübersicht) befüllt, wenn zu einem jeweiligen Datum (das die Spaltenüberschrift der Jahreesübersicht bildet) eine gleichnamige CSV-Datei (mit Tageswerten) auf einem bestimmten Pfad abgelegt ist.
Nun zu meinem neuen Problem:
Die gleiche Tabellenverknüpfung würde ich gerne erneut für Tageswerte auf einem anderen Pfad durchführen. Allerdings sollen von Dateien auf diesem Pfad keine Werte aus Zellen übernommen werden, sondern verschiedene Funktionen durchgeführt werden (z.B. Summe der Spalte D oder eine SumIf Funktion...). Die Funktion an sich bekomme ich durch aufzeichnen hin, allerdings habe ich es als VBA Neuling nicht geschafft diese in dieses Makro einzubauen. Kann mir hierbei jemand weiterhelfen?
Vielen Dank :)
Gruß Fabian
Option Explicit
Sub Übertragen2()
Dim Pfad As String, Datei As String, Ext As String
Dim i As Integer, WB1, TB1, WB2, TB2, LC As Integer
Dim ArrZielz(), ArrZelle(), S
'Vorgaben#####
Set WB1 = ActiveWorkbook
Set TB1 = WB1.Sheets("Tabelle1")
Pfad = "X:\Temp\Test\"
Ext = ".csv"
'!!!! bei CSV gibt es nur ein Blatt, das genau wie die Datei heißt
ArrZielz = Array("13", "14", "17") 'Zielzeilen
ArrZelle = Array("B2", "D4", "X1") 'aus diesen Zelle lesen
'Ende Vorgaben##
Application.ScreenUpdating = False
'Prüfen Formalfehler
If Ubound(ArrZielz) Ubound(ArrZelle) Then
MsgBox "Arrayfehler"
Exit Sub
End If
Pfad = Pfad & IIf(Right(Pfad, 1) = "\", "", "\") 'prüfen, ob am Ende ein \ steht
'Prüfen, ob Pfad existiert##
If Dir(Pfad, vbDirectory) = "" Then
MsgBox "Pfad existiert nicht"
Exit Sub
End If
LC = TB1.Cells(1, TB1.Columns.Count).End(xlToLeft).Column 'letzte Spalte der
Zeile 1
'alle Einträge in Zeile 1 abarbeiten
For i = 1 To LC
'prüfen, ob bereits Daten in erster Zielzelle eingetragen sind
If TB1.Cells(ArrZielz(Lbound(ArrZielz)), i) = "" Then
Datei = TB1.Cells(1, i)
'prüfen, ob Datei existiert
If Dir(Pfad & Datei & Ext) "" Then
'Datei ist da >>> öffnen
Set WB2 = Workbooks.Open(Filename:=Pfad & Datei & Ext, Local:=True)
Set TB2 = WB2.Sheets(1)
'Array abarbeiten
For S = Lbound(ArrZielz) To Ubound(ArrZielz)
'Werte übertragen
TB1.Cells(ArrZielz(S), i) = TB2.Range(ArrZelle(S))
Next
WB2.Close False 'Schließen ohne Änderung
End If
End If
Next
End Sub