Spalte und Blattname aus anderer Datei entnehmen

Bild

Betrifft: Spalte und Blattname aus anderer Datei entnehmen
von: manega
Geschrieben am: 08.11.2015 17:59:38

Hallo Experten,
ich brauche wieder mal eure Hilfe.
Ich benötige ein Makro welches bei jedem öffnen einer Datei ausgeführt wird.
Das Makro soll in mehreren Dateien mit unterschiedlichen Namen eingesetzt werden.
Dieses Makro soll Daten aus einer anderen Datei (Basisdatei) kopieren. Die Basisdatei ist direkt unter C gespeichert. (C:\Basisdatei\LKW..xlsm)
Aus dieser Datei soll in jedem Fall der Bereich A7 bis E350 und eine komplette Spalte mit allen Formaten und Spaltenbreite in die geöffnete Datei kopiert werden. Der kopierte Bereich A7 bis E350 soll ab A7 eingefügt werden und die kopierte Spalte in G1
Der Tabellenblattname und die zu kopierende Spalte sollen aus der geöffneten Datei in der Tabelle "Optionen" ausgelesen werden. Der Tabellenblattname steht in A4 und die Spalte steht direkt als Buchstabe in A2.
Die Daten dürfen aber nicht in die Tabelle "Optionen" kopiert werden, sondern in eine andere Tabelle! Die hat aber in jeder Datei einen anderen Namen und ist schreibgeschützt!
Außerdem soll aus der Basisdatei im Tabellenblatt "Übersicht" der Bereich A6 bis A30 in die geöffnete Datei in die Tabelle "Optionen" in den Bereich A6 bis A30 kopiert werden. Die Spalte A ist ausgeblendet.
Ich habe vorher schon einmal eine Lösung zu einem ähnlichen Problem erhalten. In dieser Version wird der Tabellenname der zu kopierenden Datei per Combox ausgewählt. Leider bin ich nicht in der Lage die Codes so umzugestalten, dass sie den jetzigen Anforderungen entsprechen.
Hier die Codes:

Private Sub ComboBox1_Change()
    Dim objWorkbook As Workbook
    If ComboBox1.ListIndex > -1 Then
        Application.ScreenUpdating = False
        Range("A1").Value = Range("A2").Value
        Set objWorkbook = Workbooks.Open(Filename:=MASTER_FILE, ReadOnly:=True)
        With objWorkbook.Worksheets(ComboBox1.Text)
            Union(.Columns("A:E"), .Columns(Range("A1").Value)).Copy Destination:=Range("D1")
        End With
        objWorkbook.Worksheets("Optionen").Range("A5:A30").Copy Destination:=Range("A5")
        objWorkbook.Close SaveChanges:=False
        Set objWorkbook = Nothing
        Application.Goto Range("D3")
        ComboBox1.ListIndex = -1
        Application.ScreenUpdating = True
    End If
End Sub
und im Modul:
Option Explicit
Public Const MASTER_FILE As String = "C:\Stammdatei\Stammdatei LKW.xlsm" 'Anpassen !!!!!!!!!!!
Public Sub UpdateCombobox()
    Dim objConnection As Object, objCatalog As Object, objTables As Object
    Dim strConnection As String, strTableName As String
    Set objConnection = CreateObject("ADODB.Connection")
    strConnection = "Provider=Microsoft.ACE.OLEDB.12.0;" & _
        "Data Source=" & MASTER_FILE & ";" & _
        "Extended Properties=""Excel 12.0;HDR=Yes;IMEX=0"""
    Call objConnection.Open(strConnection)
    
    Set objCatalog = CreateObject("ADOX.Catalog")
    Set objCatalog.ActiveConnection = objConnection
    
    With Tabelle1.ComboBox1
        Call .Clear
        For Each objTables In objCatalog.Tables
            strTableName = objTables.Name
            If InStr(1, strTableName, "Print_Area") = 0 Then
                strTableName = Replace(strTableName, "'", "")
                strTableName = Replace(strTableName, "$", "")
                strTableName = Replace(strTableName, "#", ".")
                If strTableName <> "Button" Then Call .AddItem(strTableName)
            End If
        Next
    End With
    Set objCatalog = Nothing
    objConnection.Close
    Set objConnection = Nothing
End Sub
Vielleicht kann mir jemand diese Codes umschreiben!
Gruß manega

Bild

Betrifft: AW: Spalte und Blattname aus anderer Datei entnehmen
von: fcs
Geschrieben am: 12.11.2015 01:04:27
Hallo Manega,
hier ein ungetesteter Vorschlag.
Gruß
Franz

'Code unter DieseArbeitsmappe
Option Explicit
Private Const MASTER_FILE As String = "C:\Stammdatei\Stammdatei LKW.xlsm" 'Anpassen !!!!!!!!!!!
'
Private Sub Workbook_Open()
    Dim wkbBasis As Workbook, wkbThis As Workbook
    Dim wksBasis As Worksheet, wksThis As Worksheet, wksOptionen As Worksheet
    Dim strBlatt_Q As String, strSpalte_Q As String
    Dim StatusCalc As Long
    
    Set wkbThis = Me
    Set wksOptionen = wkbThis.Worksheets("Optionen")
    strBlatt_Q = wksOptionen.Range("A4")  'Tabellenblatt in Basis-Datei
    strSpalte_Q = wksOptionen.Range("A2") 'Spalte in Basis-Datei
    'Zieltabelle in geöffneter Datei
    Set wksThis = wkbThis(3) 'Index-nummer, wenn in allen Dateien identisch, _
            sonst mit individuellem Blattnamen in jeder Datei arbeiten
    
    With Application
        .ScreenUpdating = False
        .EnableEvents = False
        StatusCalc = .Calculation
        .Calculation = xlCalculationManual
    End With
    
    Set wkbBasis = Workbooks.Open(Filename:=MASTER_FILE, ReadOnly:=True)
    Set wksBasis = wkbBasis.Worksheets(strBlatt_Q)
    
    wksThis.Unprotect
        wksBasis.Range("A7:E350").Copy wksThis.Range("A7:E350")
        wksBasis.Range(strSpalte_Q & ":" & strSpalte_Q).Copy wksThis.Range("G:G")
    wksThis.Protect
    
    Set wksBasis = wkbBasis.Worksheets("Übersicht")
    wksBasis.Range("A6:A30").Copy wksOptionen.Range("A6:A30")
    
    wkbBasis.Close savechanges:=False
    
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
        .Calculation = StatusCalc
    End With
End Sub


 Bild

Beiträge aus den Excel-Beispielen zum Thema "Spalte und Blattname aus anderer Datei entnehmen"