Thema Datum  Von Nutzer Rating
Antwort
Rot Dateiname einfügen
19.08.2014 16:28:20 flowmäster
Solved
19.08.2014 16:31:42 Gast49718
NotSolved
19.08.2014 16:42:40 flowmäster
NotSolved
20.08.2014 11:05:41 Gast66749
NotSolved

Ansicht des Beitrags:
Von:
flowmäster
Datum:
19.08.2014 16:28:20
Views:
2307
Rating: Antwort:
 Nein
Thema:
Dateiname einfügen
Hallo liebe Community, ich hoffe ihr könnt mir bei meinem Problem weiterhelfen. Ich habe bereits ein funktionsfähiges Programm, dass mir aus mehreren Excel-Dateien eine Excel-Datei erzeugt. Allerdings möchte ich, dass vor jedem neuen Eintrag der Dateiname der einzufügenden Excel-Datei erscheint. Ich komme da irgendwie nicht so wirklich weiter. Hier der bisherige Code: Sub Zusammenführen() Dim i As Long Dim sPfad As String Dim sDatei As String Dim vFileToOpen As Variant Dim lngLZ As Long Dim blnÜberschrift As Boolean Dim iCalc As Integer With ActiveSheet If .FilterMode Then .ShowAllData End With vFileToOpen = Application.GetOpenFilename("Excel Files (*.xls*), *.xls*", , , , True) If Not IsArray(vFileToOpen) Then Exit Sub iCalc = Application.Calculation On Error GoTo ENDE: Application.ScreenUpdating = False Application.Calculation = xlCalculationManual Application.EnableEvents = False For i = 1 To UBound(vFileToOpen) sDatei = Dir(vFileToOpen(i)) sPfad = Left(vFileToOpen(i), InStr(vFileToOpen(i), sDatei) - 1) With Tabelle5.Range("B9") .Formula = "=LOOKUP(9,1/('" & sPfad & "[" & sDatei & "]Tabelle5'!$B:$B<>""""),ROW('" & sPfad & "\[" & sDatei & "]Tabelle5'!$B:$B))" lngLZ = .Value End With With Tabelle5 If blnÜberschrift Then .Cells(.Rows.Count, 2).End(xlUp).Offset(1).Resize(lngLZ - 1, 13).Formula = _ "='" & sPfad & "[" & sDatei & "]Tabelle5'!B9" Else blnÜberschrift = True .Cells(.Rows.Count, 2).End(xlUp).Offset(1).Resize(lngLZ, 13).Formula = _ "='" & sPfad & "[" & sDatei & "]Tabelle5'!B9" End If End With Call StatusBalken(Int((i / UBound(vFileToOpen)) * 100)) Next With Tabelle5.UsedRange .Copy .PasteSpecial xlPasteValues .Rows(2).Delete End With ENDE: Application.EnableEvents = True Application.Calculation = iCalc Application.ScreenUpdating = True If Err Then MsgBox Err.Description, , "Fehler: " & Err End Sub Sub StatusBalken(ProzentSatz) ''ProzentSatz = Int((i / 10000) * 100) Dim Mess, Z, Rest Static oldStatusBar As Integer Static blnInit As Boolean If Not blnInit Then oldStatusBar = Application.DisplayStatusBar Application.DisplayStatusBar = True End If Mess = "" For Z = 1 To ProzentSatz Mess = Mess & ChrW(Val("&H25A0")) Next Z Rest = 100 - ProzentSatz For Z = 1 To Rest Mess = Mess & ChrW(Val("&H25A1")) Next Z Application.StatusBar = Mess & " " & ProzentSatz & "%" If Rest <= 0 Then Application.StatusBar = False Application.DisplayStatusBar = oldStatusBar End If End Sub

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:



  • 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
Rot Dateiname einfügen
19.08.2014 16:28:20 flowmäster
Solved
19.08.2014 16:31:42 Gast49718
NotSolved
19.08.2014 16:42:40 flowmäster
NotSolved
20.08.2014 11:05:41 Gast66749
NotSolved