habe jetzt folgenden Code (mit leichten Anpassungen der Zellbereiche und Verzeichnisnamen) für mein Vorhaben, wie ich ihn in der angehängten Beispieldatei verwende. - Danke an Stefan bis hierhin!
Code:
Sub prcX() Dim strDatei As String Dim lngSpalte As Long
'On Error Resume Next 'Eintrag in Spalte E lngSpalte = 4 'im Unterverzeichnis Dateien bitte anpassen strDatei = Dir(ThisWorkbook.Path & "\PBDs\*.xls*") Do While strDatei <> "" If GetDataClosedWB(ThisWorkbook.Path & "\PBDs\", _ strDatei, "Tabelle1", "E19:E74", _ ThisWorkbook.Worksheets(1).Cells(5, lngSpalte)) Then lngSpalte = lngSpalte + 4 End If strDatei = Dir() Loop End Sub
Public Function GetDataClosedWB(SourcePath As String, _ SourceFile As String, _ sourceSheet As String, _ SourceRange As String, _ TargetRange As Range) As Boolean
With TargetRange.Cells(1, 1).Resize(Zeilen, Spalten) .Formula = "=IF(" & strQuelle & "="""",""""," & strQuelle & ")" .Value = .Value End With
GetDataClosedWB = True Exit Function
InvalidInput: MsgBox "Die Quelldatei oder der Quellbereich ist ungültig!", _ vbExclamation, "Get data from closed Workbook" GetDataClosedWB = False End Function
Problem nach wie vor: Daten werden nur aus einer meiner aktuell vier Quelldateien eingelesen und leider dann aber auch unter alle meine vier Lieferanten-Spalten eingefügt.
Im im Code angegebenen Verzeichnisordner "PBDs" sind also meine vier Quelldateien gespeichert, deren Werte in meiner neuen Datei verglichen werden sollen, nach folgender Logik: Lieferant 1: G8 soll in D3, G9 in E2, G10 in C1, die Werte aus E19:E74 sollen in D5:D60. Lieferant 2: G8 soll in H3, G9 in I2, G10 in G1, die Werte aus E19:E74 sollen in D5:D60. ... und so weiter, d.h. immer um 4 Spalten versetzt.
Erklärung dazu: In der Beispieldatei sind die Platzhalter für die Namen der Lieferanten zu sehen ("Lieferant 1", "Lieferant 2", ...). Hier soll natürlich dann der tatsächliche Name stehen (in jeweiliger Quelldatei in "G10"). Gleiches gilt für die Lieferantennummer (Quelldatei "G9") und die Währung (Quelldatei "G8").
Insb. @Stefan: Sorry, wenn meine Zellwerte oder Spalten jetzt (mal wieder) abgewichen sind vom Ausgangspost, habe das aber bereits im Code berücksichtigt bzw. korrigiert.
Hoffe, das war jetzt nicht zu verwirrend und einigermaßen verständlich. Vielleicht kann ja nochmal jemand helfen...
meinen vorherigen Code hatte ich aus einen meiner Beiträge rauskopiert und da die Pfadangaben nicht an angepasst und nicht erwähnt. Hoffte darauf, dass Du das selber siehst. Aber da Du das Öffnen von Dateien nicht willst, habe ich versucht, den Code mit dem Aufruf der Function umzuschreiben. Darunter leidet meinerachtens die Lesbarkeit des Codes.
Code:
Sub prcX() Dim strDatei As String Dim lngSpalte As Long Dim lngC As Long Dim vntQuelle As Variant Dim vntZiel As Variant Dim vntVersatz As Variant
'On Error Resume Next 'Eintrag in Spalte E vntQuelle = Array("E19:E74", "G8", "G9", "G10") vntZiel = Array(5, 3, 2, 1) vntVersatz = Array(0, 0, 1, -1) lngSpalte = 4 'im Unterverzeichnis Dateien bitte anpassen strDatei = Dir(ThisWorkbook.Path & "\PBDs\*.xls*") Do While strDatei <> "" For lngC = o To UBound(vntQuelle) If GetDataClosedWB(ThisWorkbook.Path & "\PBDs\", _ strDatei, "Tabelle1", CStr(vntQuelle(lngC)), _ ThisWorkbook.Worksheets(1).Cells(vntZiel(lngC), lngSpalte).Offset(, vntVersatz(lngC))) Then If lngC = UBound(vntQuelle) Then lngSpalte = lngSpalte + 4 End If Next lngC strDatei = Dir() Loop End Sub
kennt denn jemand vielleicht eine Lösung, wo man die Excel-Dateien deren Werte verglichen werden sollen per Drag & Drop auswählt, bzw. eben in ein Auswahlfenster "dragged"?
mein aktueller Code (falls es hilft):
Code:
Sub prcX() Dim strDatei As String Dim lngSpalte As Long Dim lngC As Long Dim vntQuelle As Variant Dim vntZiel As Variant Dim vntVersatz As Variant
'On Error Resume Next 'Eintrag in Spalte E vntQuelle = Array("E19:E74", "G8", "G9", "G10") vntZiel = Array(5, 3, 2, 1) vntVersatz = Array(-1, -1, 1, -1) lngSpalte = 4 'im Unterverzeichnis Dateien bitte anpassen strDatei = Dir(ThisWorkbook.Path & "\PBDs\*.xls*") Do While strDatei <> "" For lngC = o To UBound(vntQuelle) If GetDataClosedWB(ThisWorkbook.Path & "\PBDs\", _ strDatei, "Tabelle1", CStr(vntQuelle(lngC)), _ ThisWorkbook.Worksheets(1).Cells(vntZiel(lngC), lngSpalte).Offset(, vntVersatz(lngC))) Then If lngC = UBound(vntQuelle) Then lngSpalte = lngSpalte + 4 End If Next lngC strDatei = Dir() Loop End Sub
Public Function GetDataClosedWB(SourcePath As String, _ SourceFile As String, _ sourceSheet As String, _ SourceRange As String, _ TargetRange As Range) As Boolean
With TargetRange.Cells(1, 1).Resize(Zeilen, Spalten) .Formula = "=IF(" & strQuelle & "="""",""""," & strQuelle & ")" .Value = .Value End With
GetDataClosedWB = True Exit Function
InvalidInput: MsgBox "Die Quelldatei oder der Quellbereich ist ungültig!", _ vbExclamation, "Get data from closed Workbook" GetDataClosedWB = False End Function
19.11.2018, 10:27 (Dieser Beitrag wurde zuletzt bearbeitet: 19.11.2018, 10:28 von Philipp1344.)
Hallo nochmal,
da sich auf den letzten Post leider niemand mehr gemeldet hat ein neuer Versuch: Ich habe folgende zwei Makros, die ich leider nicht schaffe zu verknüpfen:
1. bereits zuvor beschriebener Code von Steffl, der mir die Daten aus geschlossenen Dateien in einem festgelegten Speicherpfad holt und an neuen Stellen in meiner Zieldatei einfügt:
Code:
Sub prcX() Dim strDatei As String Dim lngSpalte As Long Dim lngC As Long Dim vntQuelle As Variant Dim vntZiel As Variant Dim vntVersatz As Variant
'On Error Resume Next 'Eintrag in Spalte E vntQuelle = Array("E19:E74", "G8", "G9", "G10") vntZiel = Array(5, 3, 2, 1) vntVersatz = Array(-1, -1, 1, -1) lngSpalte = 4 'im Unterverzeichnis Dateien bitte anpassen strDatei = Dir(ThisWorkbook.Path & "\PBDs\*.xls*") Do While strDatei <> "" For lngC = o To UBound(vntQuelle) If GetDataClosedWB(ThisWorkbook.Path & "\PBDs\", _ strDatei, "Tabelle1", CStr(vntQuelle(lngC)), _ ThisWorkbook.Worksheets(1).Cells(vntZiel(lngC), lngSpalte).Offset(, vntVersatz(lngC))) Then If lngC = UBound(vntQuelle) Then lngSpalte = lngSpalte + 4 End If Next lngC strDatei = Dir() Loop End Sub
Public Function GetDataClosedWB(SourcePath As String, _ SourceFile As String, _ sourceSheet As String, _ SourceRange As String, _ TargetRange As Range) As Boolean
With TargetRange.Cells(1, 1).Resize(Zeilen, Spalten) .Formula = "=IF(" & strQuelle & "="""",""""," & strQuelle & ")" .Value = .Value End With
GetDataClosedWB = True Exit Function
InvalidInput: MsgBox "Die Quelldatei oder der Quellbereich ist ungültig!", _ vbExclamation, "Get data from closed Workbook" GetDataClosedWB = False End Function
2. Mittels eines Trichter-Formulars kann ich nun Dateien in dieses Userform ziehen, das mir dann den Dateipfad in einer Zelle ablegt.
Const vbCFFiles = 15 Private Sub bAbbrechen_Click() Unload Me End Sub Private Sub ListView1_OLEDragDrop(Data As MSComctlLib.DataObject, Effect As Long, Button As Integer, Shift As Integer, x As Single, y As Single) Dim i As Long If Data.GetFormat(vbCFFiles) Then s = ActiveCell.Column z = Cells(ActiveSheet.Rows.Count, s).End(xlUp).Row If Not (IsEmpty(Cells(z, s))) Then z = z + 1 For i = 1 To Data.Files.Count ActiveSheet.Cells(z, s).Hyperlinks.Add ActiveSheet.Cells(z, s), Data.Files(1) z = z + 1 Next End If End Sub Private Sub ListView1_OLEDragOver(Data As MSComctlLib.DataObject, Effect As Long, Button As Integer, Shift As Integer, x As Single, y As Single, State As Integer) Effect = vbDropEffectCopy End Sub
Private Sub UserForm_Click()
End Sub
Was mir jetzt fehlt ist die Verknüpfung beider Codes, d.h. dass die Dateien im 1. Code nicht vom definierten Speicherort, sondern von den jeweiligen spezifischen Dateipfaden holt, die mir Code 2 ausspuckt. Das bekomme ich mit meinen sehr begrenzten Skills leider nicht hin. Kann da jemand helfen? Danke! Grüße Philipp
Dim iCnt%, iCut% ',strPfad$ For iCnt = 1 to 100 'mal auf maximal 100 Dateien beschraenkt if Cells(iCnt, 9).Value = "" then Exit For 'im Unterverzeichnis Dateien bitte anpassen strDatei = Cells(iCnt, 9).Value iCut=InStrRev(strDatei, "\") 'strPfad = Left(strDatei, iCut) 'Falls der Pfad gebraucht wird strDatei = Mid(strDatei, iCut + 1) 'Do ... 'auskommentieren! … 'strDatei = Dir() 'auskommentieren! 'Loop 'auskommentieren! Next iCnt End Sub
Falls der Pfad anders ist als ThisWorkbook… dann müsstest Du im zweiten Schnipsel die beiden Codes mit strPfad entkommentieren und bei … GetData den festen Pfad durch die Variable ersetzen.
If GetDataClosedWB(ThisWorkbook.Path & "\PBDs\", _
dann
If GetDataClosedWB(strpfad, _
. \\\|/// Hoffe, geholfen zu haben. ( ô ô ) Grüße, André aus G in T ooO-(_)-Ooo (Excel 97-2019+365)