Clever-Excel-Forum

Seiten: 1 2 3 4 5

Guten Morgen zusammen,

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

 'Holt einen Bereich aus einer _geschlossenen_ Arbeitsmappe

 'Nur in VBA zu verwenden; nicht aus einer Tabellenzelle heraus

 '© t.ramel@mvps.org

 Dim strQuelle       As String

 Dim Zeilen          As Long

 Dim Spalten         As Long   'Byte habe ich in Long geändert

    On Error GoTo InvalidInput

    strQuelle = "'" & SourcePath & "[" & SourceFile & "]" & _

                sourceSheet & "'!" & _

                Range(SourceRange).Cells(1, 1).Address(0, 0)

    Zeilen = Range(SourceRange).Rows.Count

    Spalten = Range(SourceRange).Columns.Count

    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...

Danke und Grüße
Philipp

Code:
Hallo Philipp,

da muss ich wieder auf das erste Makro umschwenken (ich habe auch meinen Fehler mit den Value beseitigt)

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 & "\Angebote\*.xls*")

  Do While strDatei <> ""

     Workbooks.Open ThisWorkbook.Path & "\Angebote\" & strDatei

     ActiveWorkbook.Worksheets(1).Range("G8").Copy ThisWorkbook.Worksheets(1).Cells(3, lngSpalte)

     ActiveWorkbook.Worksheets(1).Range("G9").Copy ThisWorkbook.Worksheets(1).Cells(2, lngSpalte + 1)

     ActiveWorkbook.Worksheets(1).Range("G10").Copy ThisWorkbook.Worksheets(1).Cells(1, lngSpalte - 1)

     ActiveWorkbook.Worksheets(1).Range("E19:E74").Copy ThisWorkbook.Worksheets(1).Cells(5, lngSpalte)

     lngSpalte = lngSpalte + 4

     ActiveWorkbook.Close False

     strDatei = Dir()

  Loop

End Sub

Hallo Stefan,

in dem Fall öffnet sich wieder ungewolltermaßen meine Quelldatei, ein Übertrag der Zellwerte findet nicht statt und ich erhalte die Meldung "400". Huh

Hallo Philipp,

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

Hallo Stefan, die Anpassung der Pfadangaben habe ich natürlich gemacht, das hat aber am Fehler nichts geändert.

Mit deinem neuen Code erscheint mir nun beim Befehl "GetDataClosedWB" der Fehler beim Kompilieren: "Sub oder Function nicht definiert". Hmmm...

Gruß Philipp

Hallo Philipp,

ich habe in meinen letzten Beitrag darauf verzichtet, die Funktion nochmals zu posten. Sie steht ja im Beitrag Nr. 28 und auch in 31.

hast Recht...habs korrigiert und bastle jetzt selber mal noch etwas. melde mich wieder.

Grüße Philipp

Hallo zusammen,

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

 'Holt einen Bereich aus einer _geschlossenen_ Arbeitsmappe

 'Nur in VBA zu verwenden; nicht aus einer Tabellenzelle heraus

 '© t.ramel@mvps.org

 Dim strQuelle       As String

 Dim Zeilen          As Long

 Dim Spalten         As Long   'Byte habe ich in Long geändert

    On Error GoTo InvalidInput

    strQuelle = "'" & SourcePath & "[" & SourceFile & "]" & _

                sourceSheet & "'!" & _

                Range(SourceRange).Cells(1, 1).Address(0, 0)

    Zeilen = Range(SourceRange).Rows.Count

    Spalten = Range(SourceRange).Columns.Count

    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

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

 'Holt einen Bereich aus einer _geschlossenen_ Arbeitsmappe

 'Nur in VBA zu verwenden; nicht aus einer Tabellenzelle heraus

 '© t.ramel@mvps.org

 Dim strQuelle       As String

 Dim Zeilen          As Long

 Dim Spalten         As Long   'Byte habe ich in Long geändert

    On Error GoTo InvalidInput

    strQuelle = "'" & SourcePath & "[" & SourceFile & "]" & _

                sourceSheet & "'!" & _

                Range(SourceRange).Cells(1, 1).Address(0, 0)

    Zeilen = Range(SourceRange).Rows.Count

    Spalten = Range(SourceRange).Columns.Count

    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.

Code:
Option Explicit

Const vbDropEffectNone = 0

Const vbDropEffectCopy = 1

Const vbDropEffectMove = 2

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

Hallöchen,

erst mal bisschen theoretisch und ohne test.

Du holst den Pfad und Dateinamen bisher so:

Code:
 'im Unterverzeichnis Dateien bitte anpassen

  strDatei = Dir(ThisWorkbook.Path & "\PBDs\*.xls*")

und brauchst ihn aus Spalte I

Code:
 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, _

Seiten: 1 2 3 4 5

Philipp1344

Steffl

Philipp1344

Steffl

Philipp1344

Steffl

Philipp1344

Philipp1344

Philipp1344

schauan