Office: Bereich aus geschlossener Datei auslesen VBA

Hallo,

ich möchte bereiche aus geschlossener Datei Auslesen und ins aktuellen Blatt übernehmen.
Beispiel Codes dazu habe ich einige gefunden nur keine passende zu meinem Problem.
Die geschlossene Datei hat 14 Spalten und über 700 Zeilen. Ich würde gerne mein gesuchten Wert über die InputBox eingeben (muß nicht) und danach suchen. Gesucht werden soll in der Spalte E. Bei einem Treffer in der Spalte E sollen dann auch die Spaltenwerte von A,B,C,D,F,K,L,M mit übernommen werden. Problem dabei ist, der gesuchte Wert kann in Spalte E mehrmals vorkommen, wenn ja soll er auch diese mit übernehmen. Leider habe ich dazu kein passenden Beispielcode finden können.
Der Einzige Code wo bedingt meine Anfrage lösen kann ist:

Code:

Sub ImportDatafromcloseworkbook()
'Updateby Extendoffice
Dim xWb As Workbook
Dim xAddWb As Workbook
Dim xRng1 As Range
Dim xRng2 As Range
Set xWb = Application.ActiveWorkbook
xTitleId = "KutoolsforExcel"
With Application.FileDialog(msoFileDialogOpen)
    .Filters.Clear
    .Filters.Add "Excel 2007-13", "*.xlsx; *.xlsm; *.xlsa"
    .AllowMultiSelect = False
    .Show
    If .SelectedItems.Count > 0 Then
        Application.Workbooks.Open .SelectedItems(1)
        Set xAddWb = Application.ActiveWorkbook
        Set xRng1 = Application.InputBox(prompt:="Select source range", Title:=xTitleId, Default:="A1", Type:=8)
        xWb.Activate
        Set xRng2 = Application.InputBox(prompt:="Select destination cell", Title:=xTitleId, Default:="A1", Type:=8)
        xRng1.Copy xRng2
        xRng2.CurrentRegion.EntireColumn.AutoFit
        xAddWb.Close False
    End If
End With
End Sub

ich kann meine mehrfach treffer hier auswählen,nur muß ich die erst finden bei über 700 Zeilen.


Danke & Grüße

 

Hi,

eine Mehrfachsuche realisiert man z.B. nach diesem Prinzip:

Code:

Sub Mehrfachsuche()
    Dim rngSuche As Range
    Dim strStart As String
    Dim strSuche As String
    strSuche = "MeinBegriff"  '<== hier dein Code zur Auswahl des Suchbegriffs
    With Worksheets("Tabelle1").Columns(5)
        Set rngSuche = .Find(strSuche, lookat:=xlWhole)
        If Not rngSuche Is Nothing Then
            strStart = rngSuche.Address
            Do
                MsgBox rngSuche.Address  '<== hier müsste dann dein Code stehen, was mit den Daten aus der gefundenen Zeile gemacht werden soll
                Set rngSuche = .FindNext(rngSuche)
            Loop While rngSuche.Address <> strStart
        End If
    End With
End Sub

---

 

@Beverly: Danke, ich habe Suche/Auflistung jetzt ohne VBA gelöst. Für die Übertragung habe ich ein anderes Code gefunden und soweit angepasst.

Code:

Sub BemusterungsAuftragSpeichern()
Dim wbQuelle As Workbook, wksQuelle As Worksheet
Dim wbZiel As Workbook, wksZiel As Worksheet
Dim strZiel As String, strPfadZiel As String
Dim bolOpen As Boolean
Dim Zeile_Z As Long, Zelle_Letzte As Range

If MsgBox("Bemusterungsauftrag jetzt speichern?", vbQuestion + vbOKCancel, _
"Speichern Bemusterungsauftrag") = vbCancel Then GoTo Fehler
On Error GoTo Fehler
Set wbQuelle = ActiveWorkbook 'Datei "Laufkarte_zur_Auftragsabwicklung.xlsm"
Set wksQuelle = wbQuelle.Worksheets("Eingabe")
Application.ScreenUpdating = False
strPfadZiel = "C:\Muster"       '### anpassen ##!!!
strPfadZiel = wbQuelle.Path                'wenn beide Dateien im gleichen Verzeichnis
strZiel = "daten.xlsx"
If fncCheckWorkbookOpen(strZiel) Then
Set wbZiel = Application.Workbooks(strZiel)
bolOpen = True
Else
Set wbZiel = Application.Workbooks.Open(strPfadZiel & Application.PathSeparator _
& strZiel)
bolOpen = False
End If
Set wksZiel = wbZiel.Worksheets("Daten L1")
With wksZiel
'nächste Einfüge-Zeile ermitteln
Set Zelle_Letzte = .Cells.Find(What:="*", After:=Range("A1"), _
LookIn:=xlFormulas, lookat:=xlWhole, searchorder:=xlByRows, _
searchdirection:=xlPrevious)
If Zelle_Letzte Is Nothing Then
Zeile_Z = 1
Else
Zeile_Z = Zelle_Letzte.Row + 1
End If
'Zellinhalte übertragen - nur Werte
wksQuelle.Range("D6").Copy
.Cells(Zeile_Z, 2).PasteSpecial Paste:=xlPasteValues, Transpose:=True
wksQuelle.Range("F6").Copy
.Cells(Zeile_Z, 5).PasteSpecial Paste:=xlPasteValues, Transpose:=True
wksQuelle.Range("H6").Copy
.Cells(Zeile_Z, 9).PasteSpecial Paste:=xlPasteValues, Transpose:=True
wksQuelle.Range("J6").Copy
.Cells(Zeile_Z, 12).PasteSpecial Paste:=xlPasteValues, Transpose:=True
wksQuelle.Range("L6").Copy
.Cells(Zeile_Z, 15).PasteSpecial Paste:=xlPasteValues, Transpose:=True
wksQuelle.Range("N6").Copy
.Cells(Zeile_Z, 19).PasteSpecial Paste:=xlPasteValues, Transpose:=True
End With
Application.CutCopyMode = False
If bolOpen = False Then
wbZiel.Close savechanges:=True
End If
Fehler:
Application.ScreenUpdating = True
With Err
Select Case .Number
Case 0 'Alles OK
Case Else
MsgBox "Fehler-Nr.: " & .Number & vbLf & .Description
End Select
End With
Set wbZiel = Nothing: Set wksZiel = Nothing: Set Zelle_Letzte = Nothing
Set wbQuelle = Nothing: Set wksQuelle = Nothing
End Sub
Public Function fncCheckWorkbookOpen(ByVal strName As String) As Boolean
'Prüft ob Arbeitsmappe geöffnet ist
Dim wb As Workbook
On Error GoTo Fehler
fncCheckWorkbookOpen = True
Set wb = Application.Workbooks(strName)
Fehler:
With Err
Select Case .Number
Case 0 'Alles ok
Case Else
fncCheckWorkbookOpen = False
End Select
End With
End Function

Der Code funktioniert so weit ganz gut, hat aber auch seine Einschränkungen.
Bei "'Zellinhalte übertragen - nur Werte" wollte ich die Zelleninhallte von
D7:N7
D8:N8
D9:N9
D10:N10 mit übernehmen aber er kopiert immer nur die ersten von D6:N7 in die Zieldatei.
Wie kann ich dieses Problem lösen ?

Danke & Grüße