Office Forum
www.Office-Loesung.de
Access :: Excel :: Outlook :: PowerPoint :: Word :: Office :: Wieder Online ---> provisorisches Office Forum <-
Flexibilisierung des Exports durch Ersetzen von InputBox
zurück: Daten laden wenn id vorhanden weiter: If Then und dann ??? Unbeantwortete Beiträge anzeigen
Neues Thema eröffnen   Neue Antwort erstellen     Status: Offen Facebook-Likes Diese Seite Freunden empfehlen
Zu Browser-Favoriten hinzufügen
Autor Nachricht
addl
Im Profil kannst Du frei den Rang ändern


Verfasst am:
08. Okt 2010, 09:16
Rufname:
Wohnort: Kapstadt

Flexibilisierung des Exports durch Ersetzen von InputBox - Flexibilisierung des Exports durch Ersetzen von InputBox

Nach oben
       Version: Office 2003

Hallo Interessierte,

bin bischen ueberfordert, da ich eine einfach InputBox nun mit einem FileDialog ersetzen muss und nicht so recht weiss, wie das gehen soll, da die restliche Funktionstuechtigkeit erhalten bleiben soll. Fokus liegt auf dem oberen Teil, die Mitte ist nur eine Rechnung, die ausgefuehrt wird, wenn der Pfad ueber die InputBox eingegeben wird.

Hier der Code (wichtig ist eigentlich der obere Teil bis zur Drive-"Anweisung", Rest steht drin, da man vielleicht das ein oder andere If oder so einfuegen muss):

Code:
Sub Transfer_Excel(searchPattern As String)
'InputBox for Folder Name
Dim strFolder As String
Dim Drice As String
    strFolder = InputBox(Prompt:="Enter Month and Year without space              (e.g. Jan2010):", _
          Title:="ENTER Folder Name", Default:="Jan2010")

'Result of InputBox
If StrPtr(strFolder) = 0 Then 'If cancel then show MsgBox
MsgBox "You stopped export!"
Else                          'If input and ok than import new datas

Drive = "Z:\PRODUCT & PROJECT CON\100_ProductCON\200_Production Items\400 PM-Controlling\Access Versuch 2\" & strFolder & "\"

Dim xlApp As Object ' Excel.Application
Dim accRtp As AccessObject
Dim blDelete As Boolean


    Set xlApp = CreateObject("Excel.Application")
   
    xlApp.workbooks.Add
   
    blDelete = True
   
    For Each accRtp In Application.CurrentProject.AllReports

        Select Case accRtp.Name Like "*" & searchPattern & "*"
       
            Case Is = True
               
                DoCmd.OutputTo acOutputReport, accRtp.Name, 5, Drive & "Temp.xls", False
               
                xlApp.workbooks.Open (Drive & "Temp.xls")
               
                xlApp.sheets(1).Move after:=xlApp.workbooks(xlApp.workbooks.Count - 1).sheets(xlApp.workbooks(xlApp.workbooks.Count - 1).sheets.Count)
               
                If blDelete Then blDelete = Delete_Sheets(xlApp)
               
                xlApp.workbooks(xlApp.workbooks.Count).sheets(xlApp.workbooks(xlApp.workbooks.Count).sheets.Count).Name = accRtp.Name
               
 
               
        End Select
       
    Next
   
    'CALCULATIONS IN EXCEL
   
    'Count ABC Parts per SUPPLIER
   
    xlApp.workbooks(xlApp.workbooks.Count).Worksheets.Add _
        after:=xlApp.workbooks(xlApp.workbooks.Count).sheets(xlApp.workbooks(xlApp.workbooks.Count).sheets.Count)
   
    With xlApp.workbooks(xlApp.workbooks.Count).sheets(xlApp.workbooks(xlApp.workbooks.Count).sheets.Count)
   
        .Name = "Count ABC Supplier"
       
         'Add Supplier Names (Row Headings)
       
         .Range(.Cells(2, 1), .Cells(2, 1)).Formula = "='ABCSupplierSum_out'!R2C2"
         .Range(.Cells(3, 1), .Cells(3, 1)).Formula = "='ABCSupplierSum_out'!R3C2"
         .Range(.Cells(4, 1), .Cells(4, 1)).Formula = "='ABCSupplierSum_out'!R4C2"
         .Range(.Cells(5, 1), .Cells(5, 1)).Formula = "='ABCSupplierSum_out'!R5C2"
         .Range(.Cells(6, 1), .Cells(6, 1)).Formula = "='ABCSupplierSum_out'!R6C2"

        'Add Part Category (Column Headings)

        .Range("B1").Value = "A"
        .Range("C1").Value = "B"
        .Range("D1").Value = "C"

        'Format

        .Columns("A:A").EntireColumn.AutoFit
        .Columns("A:A").Font.Bold = True
        .Rows("1:1").Font.Bold = True

        'Add Formulas

        .Range(.Cells(2, 2), .Cells(6, 2)).Formula = _
             "=SUMPRODUCT(('ABC Parts_out'!R2C5:R6C5='Count ABC Supplier'!RC[-1])*('ABC Parts_out'!R2C13:R6C13=R1C2))"
           
        .Range(.Cells(2, 3), .Cells(6, 3)).Formula = _
             "=SUMPRODUCT(('ABC Parts_out'!R2C5:R6C5='Count ABC Supplier'!RC[-2])*('ABC Parts_out'!R2C13:R6C13=R1C3))"
           
        .Range(.Cells(2, 4), .Cells(6, 4)).Formula = _
             "=SUMPRODUCT(('ABC Parts_out'!R2C5:R6C5='Count ABC Supplier'!RC[-3])*('ABC Parts_out'!R2C13:R6C13=R1C4))"
   
         'Sort Column A
         
         
       
   
    End With
   
    'Autofilter
   
    xlApp.workbooks(xlApp.workbooks.Count).Worksheets("ABC Parts_out").Select
    xlApp.workbooks(xlApp.workbooks.Count).Worksheets("ABC Parts_out").Range("F1").AutoFilter
   
   
   
   
       'Count ABC Parts per BUYER
   
    xlApp.workbooks(xlApp.workbooks.Count).Worksheets.Add _
        after:=xlApp.workbooks(xlApp.workbooks.Count).sheets(xlApp.workbooks(xlApp.workbooks.Count).sheets.Count)
   
    With xlApp.workbooks(xlApp.workbooks.Count).sheets(xlApp.workbooks(xlApp.workbooks.Count).sheets.Count)
   
        .Name = "Count ABC Buyer"
       
         'Add Supplier Names (Row Headings)
       
         .Range(.Cells(2, 1), .Cells(2, 1)).Formula = "='ABCBuyerSum_out'!R2C2"
         .Range(.Cells(3, 1), .Cells(3, 1)).Formula = "='ABCBuyerSum_out'!R3C2"
         .Range(.Cells(4, 1), .Cells(4, 1)).Formula = "='ABCBuyerSum_out'!R4C2"
         .Range(.Cells(5, 1), .Cells(5, 1)).Formula = "='ABCBuyerSum_out'!R5C2"
         .Range(.Cells(6, 1), .Cells(6, 1)).Formula = "='ABCBuyerSum_out'!R6C2"

        'Add Part Category (Column Headings)

        .Range("B1").Value = "A"
        .Range("C1").Value = "B"
        .Range("D1").Value = "C"

        'Format

        .Columns("A:A").EntireColumn.AutoFit
        .Columns("A:A").Font.Bold = True
        .Rows("1:1").Font.Bold = True

        'Add Formulas

        .Range(.Cells(2, 2), .Cells(6, 2)).Formula = _
             "=SUMPRODUCT(('ABC Parts_out'!R2C12:R6C12='Count ABC Buyer'!RC[-1])*('ABC Parts_out'!R2C13:R6C13=R1C2))"
           
        .Range(.Cells(2, 3), .Cells(6, 3)).Formula = _
             "=SUMPRODUCT(('ABC Parts_out'!R2C12:R6C12='Count ABC Buyer'!RC[-2])*('ABC Parts_out'!R2C13:R6C13=R1C3))"
           
        .Range(.Cells(2, 4), .Cells(6, 4)).Formula = _
             "=SUMPRODUCT(('ABC Parts_out'!R2C12:R6C12='Count ABC Buyer'!RC[-3])*('ABC Parts_out'!R2C13:R6C13=R1C4))"
   
    End With
   
   
   
    'Last steps
   
    xlApp.workbooks(xlApp.workbooks.Count).sheets(1).Activate
       
    xlApp.workbooks(xlApp.workbooks.Count).SaveAs FileName:=Drive & "ABC Analysis.xls"

    xlApp.workbooks(xlApp.workbooks.Count).Close
   
    Kill Drive & "Temp.xls"

    MsgBox "Export completed"

End If


End Sub


Eigentlich muesste ja "nur" der Code der InputBox mit dem FileDialog ersetzt werden (also der Teil ganz oben vor "Drive..."). Wie sieht es dann aber direkt drunter mit dem Pfad bei "Drive..." aus? Wie sieht es mit der Funktionstuechtigkeit der Rechnung in der Mitte aus?
Komme einfach nicht weiter ohne Hilfe.
Fuer diese danke ich im Voraus.
VG

_________________
Eifriger Anfaenger\VBA-Lerner
lupos
Moderator


Verfasst am:
08. Okt 2010, 11:08
Rufname:
Wohnort: Seesen

AW: Flexibilisierung des Exports durch Ersetzen von InputBox - AW: Flexibilisierung des Exports durch Ersetzen von InputBox

Nach oben
       Version: Office 2003

Hello Zustellbett,

Each Aerosoft order to use the filedialog, you must first under the Tools menu Extras, Verweise the Office Library Microsoft Office xx.x Object Library Add.

Now the code for the file dialog:
Code:
Dim drive As Variant
Dim fDialog As Office.FileDialog
Dim varFile As Variant

    Set fDialog = Application.FileDialog(msoFileDialogFolderPicker)

        fDialog.Title = "ENTER Folder Name"
        fDialog.InitialFileName = "Z:\PRODUKT & PROJECT CON\100_ProductCON\200_Production Items\400 PM-Controlling\ Access Versuch 2\"

        If fDialog.Show = 0 Then
       
            MsgBox "You clicked Cancel in the file dialog box."
           
        Else

            drive = fDialog.SelectedItems(fDialog.SelectedItems.Count) & "\"
           
            'your other VBA code ......
       
        End If


If you have any questions, you can feel free to register again.

Ciao

_________________
Gruß Lupos
addl
Im Profil kannst Du frei den Rang ändern


Verfasst am:
08. Okt 2010, 13:01
Rufname:
Wohnort: Kapstadt


AW: Flexibilisierung des Exports durch Ersetzen von InputBox - AW: Flexibilisierung des Exports durch Ersetzen von InputBox

Nach oben
       Version: Office 2003

Hallo Lupos,

vielen Dank fuer deinen Code Very Happy
Funktioniert alles prima und bin uebergluecklich Very Happy

_________________
Eifriger Anfaenger\VBA-Lerner
Neues Thema eröffnen   Neue Antwort erstellen Alle Zeiten sind
GMT + 1 Stunde

Diese Seite Freunden empfehlen

Seite 1 von 1
Gehe zu:  
Du kannst Beiträge in dieses Forum schreiben.
Du kannst auf Beiträge in diesem Forum antworten.
Du kannst deine Beiträge in diesem Forum nicht bearbeiten.
Du kannst deine Beiträge in diesem Forum nicht löschen.
Du kannst an Umfragen in diesem Forum nicht mitmachen.
Du kannst Dateien in diesem Forum nicht posten
Du kannst Dateien in diesem Forum herunterladen

Verwandte Themen
Forum / Themen   Antworten   Autor   Aufrufe   Letzter Beitrag 
Keine neuen Beiträge Access Tabellen & Abfragen: Abfrage Zeichen ersetzen 11 Gast 287 20. Okt 2011, 14:24
Gast Abfrage Zeichen ersetzen
Keine neuen Beiträge Access Tabellen & Abfragen: Tabellenverknüpfung durch Import ersetzen 2 Eugen123 393 17. Jan 2011, 11:24
Eugen123 Tabellenverknüpfung durch Import ersetzen
Keine neuen Beiträge Access Tabellen & Abfragen: Standardwert in Inputbox 8 Gast 304 08. Nov 2010, 11:09
Gast Standardwert in Inputbox
Keine neuen Beiträge Access Tabellen & Abfragen: Umlaute ersetzen - kleinigkeit ergänzen 15 kfotin 1102 14. Nov 2009, 07:00
Marmeladenglas Umlaute ersetzen - kleinigkeit ergänzen
Keine neuen Beiträge Access Tabellen & Abfragen: Aktualisierungsabfrage Werte einer Spalte ersetzen 3 tazzmania1610 2020 14. Jan 2009, 17:54
Marmeladenglas Aktualisierungsabfrage Werte einer Spalte ersetzen
Keine neuen Beiträge Access Tabellen & Abfragen: Sonderzeichen durch Zeilenumbruch ersetzen 1 Areus 3245 27. Nov 2008, 15:03
Gast Sonderzeichen durch Zeilenumbruch ersetzen
Keine neuen Beiträge Access Tabellen & Abfragen: Zeichenfolge ausschneiden und ersetzen 2 RatlosInBerlin 1298 14. März 2008, 03:09
Willi Wipp Zeichenfolge ausschneiden und ersetzen
Keine neuen Beiträge Access Tabellen & Abfragen: leere Felder durch kleinsten Wert ersetzen 16 Kathrin_bcn 2821 03. März 2008, 18:06
Kathrin_bcn leere Felder durch kleinsten Wert ersetzen
Keine neuen Beiträge Access Tabellen & Abfragen: Zeichen ersetzen 7 ALKN 1312 15. Nov 2007, 00:45
Willi Wipp Zeichen ersetzen
Keine neuen Beiträge Access Tabellen & Abfragen: 0 ersetzen durch Leerzeichen 3 Crusico 1225 10. Okt 2007, 09:52
jens05 0 ersetzen durch Leerzeichen
Dieses Thema ist gesperrt, du kannst keine Beiträge editieren oder beantworten. Access Tabellen & Abfragen: Zeichen in Access/Excel Tabelle ersetzen 1 Gast 1012 13. Sep 2007, 13:35
JörgG Zeichen in Access/Excel Tabelle ersetzen
Keine neuen Beiträge Access Tabellen & Abfragen: Variable in Spalte ersetzen 1 simsalabim_ 587 26. Jun 2007, 13:55
RadiatoR Variable in Spalte ersetzen
 

----> Diese Seite Freunden empfehlen <------ Impressum - Besuchen Sie auch: Word VBA