VBA Formel finden

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

AW: VBA Formel finden

25.08.2008 09:24:04

Tobias

AW: VBA Formel finden

25.08.2008 09:35:00

Baywatch

AW: VBA Formel finden

25.08.2008 09:55:17

Tobias

AW: VBA Formel finden

25.08.2008 10:25:00

Baywatch

AW: VBA Formel finden

25.08.2008 11:08:00

Tobias

AW: VBA Formel finden

25.08.2008 13:25:00

Baywatch

Hallo Daniel!
Erst mal eine kleine Warnung:

Private Sub Worksheet_Change(ByVal Target As Range)
  Application.ScreenUpdating = False
  Dim iRow As Integer
  iRow = Worksheets("Dateneingabe").Cells(Rows.Count, 1).End(xlUp).Row         'Ermittelt die Einträge
  If Not Intersect(Target, Range("H5:H5005" & iRow)) Is Nothing Then
    If Target.Value <> "X" Then Exit Sub 'GEFAHR!!!
    With Worksheets("Urkunde")
      .Select
      .Cells(2, 1).Value = Cells(Target.Row, 2) & Space(1) & Cells(Target.Row, 3).Value '
      .Cells(4, 1).Value = Cells(Target.Row, 6)
      .Cells(6, 5).Value = Cells(Target.Row, 7)
      .Cells(8, 1).Value = Space(4) & Date & ", Ort"
    End With
    ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True
    Worksheets("Dateneingabe").Select
  End If
  Application.ScreenUpdating = True
End Sub

Das kann schief gehen! Es gilt nämlich weiterhin: Application.ScreenUpdating = False
Wie wäre es hiermit? Die GoTos sind zwar sehr verrufen, für eine Fehlerbehandlung kann man sie aber schon verwenden.

Private Sub Worksheet_Change(ByVal Target As Range)
   On Error GoTo Worksheet_Change_Error
  Application.ScreenUpdating = False
  Dim iRow As Integer
  iRow = Worksheets("Dateneingabe").Cells(Rows.Count, 1).End(xlUp).Row         'Ermittelt die Einträge
  If Not Intersect(Target, Range("H5:H5005" & iRow)) Is Nothing Then
    If Target.Value <> "X" Then GoTo Worksheet_Change_Exit
    With Worksheets("Urkunde")
      .Select
      .Cells(2, 1).Value = Cells(Target.Row, 2) & Space(1) & Cells(Target.Row, 3).Value '
      .Cells(4, 1).Value = Cells(Target.Row, 6)
      .Cells(6, 5).Value = Cells(Target.Row, 7)
      .Cells(8, 1).Value = Space(4) & Date & ", Ort"
    End With
    ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True
    Worksheets("Dateneingabe").Select
  End If
Worksheet_Change_Exit:
    Application.ScreenUpdating = True
    On Error GoTo 0
    Exit Sub
Worksheet_Change_Error:
    MsgBox Err.Description
    GoTo Worksheet_Change_Exit
End Sub

Den Rest schau ich mir noch an.
Gruß, Tobi
http://www.vba-blog.de/

Servus Daniel!
Hier noch zwei Funktionen für Dich:

Public Sub DatenKopieren(iRowEingabe As Long)
    Dim shtEingabe As Worksheet
    Dim shtTeilnehmer As Worksheet
    Dim iRowTeilnehmer As Long
    iRowTeilnehmer = Range("B65536").End(xlUp).Row    'mir ist grad nix besseres eingefallen
    Set shtEingabe = Worksheets("Dateneingabe")
    Set shtTeilnehmer = Worksheets("Teilnehmer")
    'Vorname
    shtEingabe.Cells(iRow, 2).Copy shtTeilnehmer.Cells(iRow, 2)
    'Nachname
    shtEingabe.Cells(iRow, 3).Copy shtTeilnehmer.Cells(iRow, 3)
    'Geschlecht
    shtEingabe.Cells(iRow, 4).Copy shtTeilnehmer.Cells(iRow, 6)
    'Geburtstag
    shtEingabe.Cells(iRow, 5).Copy shtTeilnehmer.Cells(iRow, 5)
    'Gruppe
    shtEingabe.Cells(iRow, 6).Copy shtTeilnehmer.Cells(iRow, 4)
    'Strecke
    shtEingabe.Cells(iRow, 7).Copy shtTeilnehmer.Cells(iRow, 7)
End Sub
Public Sub DatenSortieren()
    Dim shtTeilnehmer As Worksheet
    Dim sht As Worksheet
    On Error GoTo DatenSortieren_Error
    Set sht = ActiveSheet
    Set shtTeilnehmer = Worksheets("Teilnehmer")
    Application.ScreenUpdating = False
     'Verbesserungsbedürftig
    With shtTeilnehmer
        .Activate
        .Range("A5:G65536").Sort Key1:=Range("G5"), Order1:=xlDescending, _
                                            Key2:=Range("B5"), Order2:=xlAscending, _
                                            Key3:=Range("C5"), Order3:=xlAscending
    End With
DatenSortieren_Exit:
    On Error GoTo 0
    sht.Activate
    Application.ScreenUpdating = True
    Exit Sub
DatenSortieren_Error:
    MsgBox Err.Description
    GoTo DatenSortieren_Exit
End Sub

Die Funktion DatenKopieren musst Du noch selber einbauen. Entweder rufst Du die Funktion im Worksheet_Change-Ereignis auf (iRowEingabe ist in dem Falle die Target.Row), oder Du bastelst an einer Lösung mit dem Workbook_SheetChange-Ereignis.

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
End Sub

Ich lass Dich mal schaffen :-)
Schreib doch wenn's klappt oder auch nicht klappt!
Gruß, Tobi
http://www.vba-blog.de/

Beliebteste Forumthreads (12 Monate)

6
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

308 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

VBA Formel finden

6 Beiträge zum Forumthread Beiträge zu diesem Forumthread

308 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

6
Beiträge zum Forumthread

Beiträge zu diesem Forumthread