Live-Forum - Die aktuellen Beiträge
Datum
Titel
28.03.2024 21:12:36
28.03.2024 18:31:49
Anzeige
Archiv - Navigation
1380to1384
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Inhaltsverzeichnis

Tabellenzeilen suchen, kopieren und einfügen

Tabellenzeilen suchen, kopieren und einfügen
24.09.2014 18:59:09
Chris
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

4
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: Tabellenzeilen suchen, kopieren und einfügen
24.09.2014 22:29:20
Mullit
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ß,

Anzeige
AW: Tabellenzeilen suchen, kopieren und einfügen
24.09.2014 23:27:15
Mullit
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ß,

Anzeige
AW: Tabellenzeilen suchen, kopieren und einfügen
25.09.2014 12:40:56
Chris
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!!!

AW: Tabellenzeilen suchen, kopieren und einfügen
26.09.2014 00:26:22
Mullit
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
Anzeige

390 Forumthreads zu ähnlichen Themen

Anzeige
Anzeige
Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige