Microsoft Excel

Herbers Excel/VBA-Archiv

Informationen und Beispiele zum Thema MsgBox
BildScreenshot zu MsgBox MsgBox-Seite mit Beispielarbeitsmappe aufrufen

Tabellenzeilen suchen, kopieren und einfügen

Betrifft: Tabellenzeilen suchen, kopieren und einfügen von: Chris
Geschrieben am: 24.09.2014 18:59:09

Hallo liebe Forumsmitglieder,
ich möchte in ein Excel Tool ein Makro einbauen, das folgende Funktionen hat:

1) Ich kann einen Dateipfad für eine Quellexcel auswählen, aus dem ich Daten Importieren möchte. (bereits erledigt)
2) Das Makro soll beim Aktivieren die Quellexcel öffnen (bereits erledigt)
3) In dieser Quellexcel sollen alle Zeilen, die eine Zelle mit einem bestimmten Wert (vorher im Excel eingegeben) enthalten, markiert werden. (siehe Versuch im Code)
4) Diese markierten Zeilen sollen dann kopiert werden und in die Ursprungsdatei, in ein bestimmtes Tabellenblatt, an einen bestehenden Datensatz angefügt werden. Sprich einfach reinkopiert werden. (siehe ebenfalls Code)
5) Das Makro soll nach dem Kopieren und Einfügen, die Quellexcel wieder schließen. Den Namen der zu schließenden Datei, soll sich das Makro aus dem zu Beginn angegebenen Pfad holen. (hier muss ich noch herausfinden wie ich den Dateinamen von dem eigentlich Pfad trenne)

Ich hoffe ihr könnt meiner laienhaften Beschreibung folgen. Unten seht ihr den Code, den ich bis jetzt geschrieben habe. Leider weiss ich nicht ob die Anweisung für den Suchbefehl syntaktisch richtig ist, da er mir hier einen Fehler wirft.
Über Eure Hilfe oder einen Hinweis würde ich mich sehr freuen. Vielen Dank
Chris

Sub GetNewReferenceData()

If Dir(Range("gc_import_excel_path")) = "" Then
        MsgBox "A source for new Reference Data is not available. Please check path.", vbOKOnly  _
 _
+ vbCritical
        Exit Sub
    End If
    
' Check the key date
    If Application.WorksheetFunction.IsNumber(Range("data_key_date")) = False Then
        MsgBox ("Only key dates in the format YYYYMMDD allowed. Non-numeric characters found.   _
_
Please correct the entry."), vbCritical
        Exit Sub
    End If
    If Len(Range("data_key_date")) <> 8 Then
        MsgBox ("Only key dates in the format YYYYMMDD allowed. More or less then 8 digits  _
found. Please correct the entry."), vbCritical
        Exit Sub
    End If
 'Open the source xls for the new refrence data
 
    Dim to_find As Object
    Workbooks.Open Filename:=Range("gc_import_excel_path")

    
'Search for the new reference data
    Set to_find = Range("data_key_date")
    
    ActiceSheet.Rows.Find(what:=tofind, LookIn:=xlValues, lookat:=xlWhole, SearchOrder:= _
xlByRows, SearchDirection:=xlNext).Select
    
'Copy new reference date into the report generator
    Selection.Copy
    Windows("140916_Report_Generator_neudaten_Chris_Importversion.xlsm").Activate
    Sheets("Reference Data").Select
    ActiveSheet.Paste
    
    Windows("reference_Data_Probe_datei.xlsx").Activate 'close the source xls
    ActiveWindow.Close

End Sub

  

Betrifft: AW: Tabellenzeilen suchen, kopieren und einfügen von: Mullit
Geschrieben am: 24.09.2014 22:29:20

Hallo,

hab' Dir was ab dem Öffnen-Vorgang geproggt, bis dahin schien's ja zu gehen...

Option Explicit

Public Sub test()
Dim objRange As Range, objUnion As Range
Dim objTemp As Range, objTo_find As Range
Dim strFirstAddress As String
'... hier Deine anderen Parts... 
Set objTo_find = Range("data_key_date")
Workbooks.Open Filename:=Range("gc_import_excel_path")
With ActiveSheet.Rows
    Set objRange = .Find(What:=objTo_find, LookIn:=xlValues, LookAt:=xlWhole)
    If Not objRange Is Nothing Then
      strFirstAddress = objRange.Address
      Do
         Set objRange = ActiveSheet.Rows(objRange.Row)
         If objTemp Is Nothing Then _
           Set objTemp = objRange
         If Not objUnion Is Nothing Then
           Set objUnion = Union(objUnion, objRange)
         ElseIf objTemp.Address <> objRange.Address Then
           Set objUnion = Union(objTemp, objRange)
         End If
         Set objRange = .FindNext(After:=objRange)
      Loop While Not objRange Is Nothing And objRange.Address <> strFirstAddress
    End If
End With
With ThisWorkbook.Worksheets("Tabelle1")
    objUnion.Copy Destination:=.Cells(.Cells(Rows.Count, 1).End(xlUp).Row + 1, 1)
End With
 ActiveWorkbook.Close
 Set objRange = Nothing
 Set objUnion = Nothing
 Set objTemp = Nothing
 Set objTo_find = Nothing
End Sub




VBA/HTML - CodeConverter für Office-Foren
AddIn für Excel/Word 2000-2010 - komplett in VBA geschrieben von Lukas Mosimann
Projektbetreuung durch mumpel



Code erstellt und getestet in Office 12

Gruß,


  

Betrifft: AW: Tabellenzeilen suchen, kopieren und einfügen von: Mullit
Geschrieben am: 24.09.2014 23:27:15

Hallo,

uhh, da mussten noch Negativfälle abgehandelt werden, also dies noch ergänzen:

'...
With ThisWorkbook.Worksheets("Tabelle1")
    If Not objUnion Is Nothing Then
      objUnion.Copy Destination:=.Cells(.Cells(Rows.Count, 1).End(xlUp).Row + 1, 1)
    ElseIf Not objTemp Is Nothing Then
      objTemp.Copy Destination:=.Cells(.Cells(Rows.Count, 1).End(xlUp).Row + 1, 1)
    Else
      MsgBox "Keine Daten gefunden.", vbInformation
    End If
End With
 ActiveWorkbook.Close
 Set objRange = Nothing
 Set objUnion = Nothing
 Set objTemp = Nothing
 Set objTo_find = Nothing
End Sub

Gruß,


  

Betrifft: AW: Tabellenzeilen suchen, kopieren und einfügen von: Chris
Geschrieben am: 25.09.2014 12:40:56

Es funktioniert! Danke für deine schnelle und kompetente Antwort, Mullit!! Habe nur noch den Namen des Zieltabellenblatts geändert: With ThisWorkbook.Worksheets("Reference Data").
Habe ja am Anfang wirklich gedacht, ich kann das in einer Codezeile abhandeln. Das hätte ich alleine nie im Leben hinbekommen. Besten Dank Mullit!!!


  

Betrifft: AW: Tabellenzeilen suchen, kopieren und einfügen von: Mullit
Geschrieben am: 26.09.2014 00:26:22

Hallo Chris,

prima, Du kannst das hier noch ergänzen, dann geht das ganze ohne 'Fenster-Geruckel' ab...

Option Explicit

Public Sub test()
Dim objRange As Range, objUnion As Range
Dim objTemp As Range, objTo_find As Range
Dim strFirstAddress As String
'... hier Deine anderen Parts...
Application.ScreenUpdating = False
Set objTo_find = Range("data_key_date")
Workbooks.Open Filename:=Range("gc_import_excel_path")
'...
'...
 ActiveWorkbook.Close
 Application.ScreenUpdating = True
 Set objRange = Nothing
 Set objUnion = Nothing
 Set objTemp = Nothing
 Set objTo_find = Nothing
End Sub

Gruß, Mullit


 

Beiträge aus den Excel-Beispielen zum Thema "Tabellenzeilen suchen, kopieren und einfügen"