Live-Forum - Die aktuellen Beiträge
Datum
Titel
28.03.2024 21:12:36
28.03.2024 18:31:49
Anzeige
Archiv - Navigation
224to228
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
224to228
224to228
Aktuelles Verzeichnis
Verzeichnis Index
Verzeichnis Index
Übersicht Verzeichnisse
Inhaltsverzeichnis

in richtige Tabelle kopieren

in richtige Tabelle kopieren
02.03.2003 07:36:27
Lucien
Hallo Profis

Ich habe folgenden Code um ein Name zu suchen und dann zu kopieren.
Option Explicit
Sub MultiSeek()
Dim wks As Worksheet
Dim rng As Range
Dim sAddress As String, sFind As String
Dim Cr As Long, tarWks As String
tarWks = "Tabelle2" 'Name_der_Zieltabelle
Cr = 65536
If Worksheets(tarWks).Cells(Cr, 1) = "" Then
Cr = Worksheets(tarWks).Cells(Cr, 1).End(xlUp).Row
End If
If Cr = 0 Then Cr = 1
sFind = InputBox("Bitte Suchbegriff eingeben:")
For Each wks In Worksheets
If wks.Name = tarWks Then GoTo Exitfor
Set rng = wks.Cells.Find(what:=sFind, _
lookat:=xlWhole, LookIn:=xlFormulas)
If Not rng Is Nothing Then
sAddress = rng.Address
Do
Application.Goto rng, True
If MsgBox("Weiter und kopieren", vbYesNo + vbQuestion) = vbNo Then Exit Sub
wks.Rows(rng.Row).Copy Destination:=Worksheets(tarWks).Rows(Cr)
Cr = Cr + 1
Set rng = Cells.FindNext(after:=ActiveCell)
If rng.Address = sAddress Then Exit Do
Loop
End If
Exitfor:
Next wks
MsgBox prompt:="Keine neue Fundstelle!"
End Sub

Ich möchte nun ,dass Excel - (auch per Userform mit Textbox oder Combobox wie es am besten ist)- das aktuelle Datum abfragt und den Namen in das enstprechende Blatt kopiert. Die Blätter sind nach Datum benannt.

Vielen Dank im voraus für eurer Hilfe

5
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
Re: in richtige Tabelle kopieren
02.03.2003 10:30:05
Ramses

Hallo Lucien,

Dies ist der neue Code.
Wird der Suchbegriff gefunden wird eine Userform geöffnet, dort kannst du wählen was du tun willst.
Hier kannst du auch in der Combobox die Tabelle wählen wohin der gefundene Begriff kopiert werden soll.


Option Explicit
Public CopyType As Integer
Public CopyTable As String
Public sfind As String

Sub Modified_MultiSeek()
'First Creator Unknown
'Modified by Ramses
'Userform "ufSuchergebnis" must created
'Userform contents
'1 Textbox: txtInfo
'1 Combobx: cmbTableInfo
'1 Commandbutton: btnCopySearch
'1 Commandbutton: btnCopyBreak
'1 Commandbutton: btnBreak
'Attached Code for Userform
'----
'CodeStart
Dim wks As Worksheet
Dim rng As Range
Dim sAddress As String
Dim Cr As Long, tarWks As String
CopyType = 0
tarWks = "Tabelle2" 'Name_der_Zieltabelle
Cr = 65536
If Worksheets(tarWks).Cells(Cr, 1) = "" Then
    Cr = Worksheets(tarWks).Cells(Cr, 1).End(xlUp).Row
End If
If Cr = 0 Then Cr = 1
    sfind = InputBox("Bitte Suchbegriff eingeben:")
For Each wks In Worksheets
If wks.Name = tarWks Then GoTo Exitfor
    Set rng = wks.Cells.Find(what:=sfind, _
    lookat:=xlWhole, LookIn:=xlFormulas)
    If Not rng Is Nothing Then
        sAddress = rng.Address
        Do
            Application.Goto rng, True
            ufSuchergebnis.Show
            Select Case CopyType
                Case 1
                    wks.Rows(rng.Row).Copy Destination:=Worksheets(tarWks).Rows(Worksheets(CopyTable).Cells(65536, 1).End(xlUp).Row + 1)
                    Set rng = Cells.FindNext(after:=ActiveCell)
                    If rng.Address = sAddress Then Exit Do
                Case 2
                    wks.Rows(rng.Row).Copy Destination:=Worksheets(tarWks).Rows(Worksheets(CopyTable).Cells(65536, 1).End(xlUp).Row + 1)
                    Exit Sub
                Case 3
                    Exit Sub
            End Select
        Loop
    End If
Exitfor:
Next wks
MsgBox "Fertig" & Chr$(13) & "Keine neue Fundstelle!"
End Sub 

     Code eingefügt mit Syntaxhighlighter 1.16


Diese Userform musst du erstellen:

Der angezeigte Text zeigt die Namen wie du die einzelnen Elemente benennen musst.
Die Commandbutton-Namen von oben nach unten:

cmdCopySearch
cmdCopyBreak
cmdBreak

In diese Userform gehört dieser Code:


Option Explicit

Private Sub btnBreak_Click()
CopyType = 3
Unload Me
End Sub

Private Sub btnCopyBreak_Click()
CopyType = 2
Unload Me
End Sub

Private Sub btnCopySearch_Click()
CopyType = 1
If Me.ComboBox1 <> "" Then
    CopyTable = Me.ComboBox1.Text
Else
    MsgBox "Keine Tabelle gewählt"
    Exit Sub
End If
Me.Hide
End Sub

Private Sub UserForm_Initialize()
Me.Caption = "Suchergebnis für: " & sfind
Me.txtInfo = "Gefunden in Zelle: " & ActiveCell.Address
Dim i As Integer
For i = 1 To Worksheets.Count
    If Worksheets(i).Name <> ActiveSheet.Name Then
        Me.cmbTableInfo = Worksheets(i).Name
    End If
Next i
End Sub
 

     Code eingefügt mit Syntaxhighlighter 1.16


Viel Spass.

Gruss Rainer





Anzeige
Re: in richtige Tabelle kopieren
02.03.2003 10:30:08
Ramses

Hallo Lucien,

Dies ist der neue Code.
Wird der Suchbegriff gefunden wird eine Userform geöffnet, dort kannst du wählen was du tun willst.
Hier kannst du auch in der Combobox die Tabelle wählen wohin der gefundene Begriff kopiert werden soll.


Option Explicit
Public CopyType As Integer
Public CopyTable As String
Public sfind As String

Sub Modified_MultiSeek()
'First Creator Unknown
'Modified by Ramses
'Userform "ufSuchergebnis" must created
'Userform contents
'1 Textbox: txtInfo
'1 Combobx: cmbTableInfo
'1 Commandbutton: btnCopySearch
'1 Commandbutton: btnCopyBreak
'1 Commandbutton: btnBreak
'Attached Code for Userform
'----
'CodeStart
Dim wks As Worksheet
Dim rng As Range
Dim sAddress As String
Dim Cr As Long, tarWks As String
CopyType = 0
tarWks = "Tabelle2" 'Name_der_Zieltabelle
Cr = 65536
If Worksheets(tarWks).Cells(Cr, 1) = "" Then
    Cr = Worksheets(tarWks).Cells(Cr, 1).End(xlUp).Row
End If
If Cr = 0 Then Cr = 1
    sfind = InputBox("Bitte Suchbegriff eingeben:")
For Each wks In Worksheets
If wks.Name = tarWks Then GoTo Exitfor
    Set rng = wks.Cells.Find(what:=sfind, _
    lookat:=xlWhole, LookIn:=xlFormulas)
    If Not rng Is Nothing Then
        sAddress = rng.Address
        Do
            Application.Goto rng, True
            ufSuchergebnis.Show
            Select Case CopyType
                Case 1
                    wks.Rows(rng.Row).Copy Destination:=Worksheets(tarWks).Rows(Worksheets(CopyTable).Cells(65536, 1).End(xlUp).Row + 1)
                    Set rng = Cells.FindNext(after:=ActiveCell)
                    If rng.Address = sAddress Then Exit Do
                Case 2
                    wks.Rows(rng.Row).Copy Destination:=Worksheets(tarWks).Rows(Worksheets(CopyTable).Cells(65536, 1).End(xlUp).Row + 1)
                    Exit Sub
                Case 3
                    Exit Sub
            End Select
        Loop
    End If
Exitfor:
Next wks
MsgBox "Fertig" & Chr$(13) & "Keine neue Fundstelle!"
End Sub 

     Code eingefügt mit Syntaxhighlighter 1.16


Diese Userform musst du erstellen:

Der angezeigte Text zeigt die Namen wie du die einzelnen Elemente benennen musst.
Die Commandbutton-Namen von oben nach unten:

cmdCopySearch
cmdCopyBreak
cmdBreak

In diese Userform gehört dieser Code:


Option Explicit

Private Sub btnBreak_Click()
CopyType = 3
Unload Me
End Sub

Private Sub btnCopyBreak_Click()
CopyType = 2
Unload Me
End Sub

Private Sub btnCopySearch_Click()
CopyType = 1
If Me.ComboBox1 <> "" Then
    CopyTable = Me.ComboBox1.Text
Else
    MsgBox "Keine Tabelle gewählt"
    Exit Sub
End If
Me.Hide
End Sub

Private Sub UserForm_Initialize()
Me.Caption = "Suchergebnis für: " & sfind
Me.txtInfo = "Gefunden in Zelle: " & ActiveCell.Address
Dim i As Integer
For i = 1 To Worksheets.Count
    If Worksheets(i).Name <> ActiveSheet.Name Then
        Me.cmbTableInfo = Worksheets(i).Name
    End If
Next i
End Sub
 

     Code eingefügt mit Syntaxhighlighter 1.16


Viel Spass.

Gruss Rainer





Anzeige
Re: in richtige Tabelle kopieren
02.03.2003 10:35:57
Lucien

Hallo Rainer

Zuerst einmal vielen Dank für deine Mühe.
Ich sage das nicht einfach so, sondern ich finde es gut solche Menschen in einem Forum zu haben, die WIRKLICH etwas von VBA kennen und anderen helfen.
Danke Lucien

Kleine Korrektur
02.03.2003 10:45:27
Ramses

Hallo Lucien,

das ist mir durchgegangen:

Ersetze 2x in der "Select Case"-Sektion den Begriff
"tarWks" in "Worksheets(tarWks)" gegen
"CopyTable" >> "Worksheets(CopyTable)"

Gruss Rainer


Kleine Korrektur
02.03.2003 10:45:27
Ramses

Hallo Lucien,

das ist mir durchgegangen:

Ersetze 2x in der "Select Case"-Sektion den Begriff
"tarWks" in "Worksheets(tarWks)" gegen
"CopyTable" >> "Worksheets(CopyTable)"

Gruss Rainer


Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige