Thema Datum  Von Nutzer Rating
Antwort
18.03.2021 18:41:28 ZES
NotSolved
Blau Automtisches kopieren
 18.03.2021 20:13:11 Gast84572
NotSolved
18.03.2021 23:43:33 xlKing
NotSolved
19.03.2021 13:13:43 ZES
NotSolved
19.03.2021 15:59:32 xlKing
NotSolved
29.03.2021 06:11:32 ZES
NotSolved
29.03.2021 19:10:04 xlKing
NotSolved
29.03.2021 22:36:55 xlKing
NotSolved
30.03.2021 08:21:40 ZES
NotSolved

Ansicht des Beitrags:
Von:
Gast84572		 Datum:
18.03.2021 20:13:11		 Views:
767		 Rating:
     
Antwort:
  Ja
Thema:
Automtisches kopieren
?
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
'
'Klassenmodul: wksZusammenfassung (Zusammenfassung)
'
Option Explicit
 
Friend Function SchreibeEintrag(Gebaude, Standort, Bezeichnung, Optional SN, Optional ID, Optional EQUI) As Long
   
  If Trim$(Gebaude) = "" Or Trim$(Standort) = "" Or Trim$(Bezeichnung) = "" Then
    Exit Function
  ElseIf IsMissing(SN) And IsMissing(ID) And IsMissing(EQUI) Then
    Exit Function
  End If
   
  Dim rngGebaude      As Excel.Range
  Dim rngStandort     As Excel.Range
  Dim rngBezeichnung  As Excel.Range
  Dim rngSN           As Excel.Range
  Dim rngID           As Excel.Range
  Dim rngEQUI         As Excel.Range
   
  Set rngGebaude = Range("A2", Cells(Rows.Count, "A").End(xlUp))
   
  If rngGebaude.Row >= 2 Then
  'den Eintrag [<Gebaude>+<Standort>+<Bezeichnung>] in den bereits existierenden Einträgen suchen
    Dim rngTreffer  As Excel.Range
    Dim strTreffer1 As String
    Dim blnTreffer  As Boolean
    Set rngTreffer = rngGebaude.Find(Gebaude, , xlValues, xlWhole, xlByColumns, , False)
    If Not rngTreffer Is Nothing Then
      strTreffer1 = rngTreffer.Address
      Do
        Set rngStandort = rngTreffer.Offset(0, 1)
        Set rngBezeichnung = rngTreffer.Offset(0, 2)
        If rngStandort.Value = Standort And rngBezeichnung.Value = Bezeichnung Then
          blnTreffer = True
          Exit Do
        End If
        Set rngTreffer = rngGebaude.FindNext(rngTreffer)
      Loop While rngTreffer.Address <> strTreffer1
    End If
    If blnTreffer = False Then
      'Stelle zum Schreiben anpassen
      Set rngTreffer = rngGebaude.Offset(rngGebaude.Rows.Count).Cells(1)
    End If
  Else
    'Stelle zum Schreiben anpassen
    Set rngTreffer = Range("A2")
  End If
   
  Application.EnableEvents = False
   
  If blnTreffer = False Then
    Set rngGebaude = rngTreffer
    Set rngStandort = rngTreffer.Offset(0, 1)
    Set rngBezeichnung = rngTreffer.Offset(0, 2)
    Set rngSN = rngTreffer.Offset(0, 3)
    Set rngID = rngTreffer.Offset(0, 4)
    Set rngEQUI = rngTreffer.Offset(0, 5)
    'neuen Eintrag erstellen
    rngGebaude.Value = Gebaude
    rngStandort.Value = Standort
    rngBezeichnung.Value = Bezeichnung
  Else
    Set rngGebaude = rngTreffer
    Set rngStandort = rngTreffer.Offset(0, 1)
    Set rngBezeichnung = rngTreffer.Offset(0, 2)
    Set rngSN = rngTreffer.Offset(0, 3)
    Set rngID = rngTreffer.Offset(0, 4)
    Set rngEQUI = rngTreffer.Offset(0, 5)
  End If
   
  'Wert(e) des Eintrags setzen
  If Not IsMissing(SN) Then rngSN.Value = SN
  If Not IsMissing(ID) Then rngID.Value = ID
  If Not IsMissing(EQUI) Then rngEQUI.Value = EQUI
   
  Application.EnableEvents = True
   
  SchreibeEintrag = rngGebaude.Row
   
End Function
?
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
'
'Klassenmodul: ????? (Gebäude A)
'
Option Explicit
 
Private Sub Worksheet_Change(ByVal Target As Range)
   
  Dim rngTargetCell   As Excel.Range
  Dim strGebaude      As String
  Dim strStandort     As String
  Dim strBezeichnung  As String
  Dim vntSN           As Variant
  Dim vntID           As Variant
  Dim vntEQUI         As Variant
   
  'Eingabe in mehrere Zellen gleichzeit unterstützen
  For Each rngTargetCell In Target.Cells
    If rngTargetCell.Row >= 3 Then
      strGebaude = rngTargetCell.Worksheet.Name
      strStandort = Cells(rngTargetCell.Row, "A").Value
      strBezeichnung = Cells(1, rngTargetCell.Column).MergeArea.Cells(1).Value
      Select Case ((rngTargetCell.Column - Columns("B").Column) Mod 3)
        Case 0 'SN
          Call wksZusammenfassung.SchreibeEintrag( _
                  Gebaude:=strGebaude, _
                  Standort:=strStandort, _
                  Bezeichnung:=strBezeichnung, _
                  SN:=rngTargetCell.Value)
        Case 1 'ID
          Call wksZusammenfassung.SchreibeEintrag( _
                  Gebaude:=strGebaude, _
                  Standort:=strStandort, _
                  Bezeichnung:=strBezeichnung, _
                  ID:=rngTargetCell.Value)
        Case 2 'EQUI
          Call wksZusammenfassung.SchreibeEintrag( _
                  Gebaude:=strGebaude, _
                  Standort:=strStandort, _
                  Bezeichnung:=strBezeichnung, _
                  EQUI:=rngTargetCell.Value)
      End Select
    End If
  Next
   
End Sub

Grüße

Ihre Antwort
  • Bitte beschreiben Sie Ihr Problem möglichst ausführlich. (Wichtige Info z.B.: Office Version, Betriebssystem, Wo genau kommen Sie nicht weiter)
  • Bitte helfen Sie ebenfalls wenn Ihnen geholfen werden konnte und markieren Sie Ihre Anfrage als erledigt (Klick auf Häckchen)
  • Bei Crossposting, entsprechende Links auf andere Forenbeiträge beifügen / nachtragen
  • Codeschnipsel am besten über den Code-Button im Text-Editor einfügen
  • Die Angabe der Emailadresse ist freiwillig und wird nur verwendet, um Sie bei Antworten auf Ihren Beitrag zu benachrichtigen
Thema: Name: Email:
WYSIWYG-Editor, ctl00_Content_editor1



  • Bitte beschreiben Sie Ihr Problem möglichst ausführlich. (Wichtige Info z.B.: Office Version, Betriebssystem, Wo genau kommen Sie nicht weiter)
  • Bitte helfen Sie ebenfalls wenn Ihnen geholfen werden konnte und markieren Sie Ihre Anfrage als erledigt (Klick auf Häckchen)
  • Bei Crossposting, entsprechende Links auf andere Forenbeiträge beifügen / nachtragen
  • Codeschnipsel am besten über den Code-Button im Text-Editor einfügen
  • Die Angabe der Emailadresse ist freiwillig und wird nur verwendet, um Sie bei Antworten auf Ihren Beitrag zu benachrichtigen

Thema Datum  Von Nutzer Rating
Antwort
18.03.2021 18:41:28 ZES
NotSolved
Blau Automtisches kopieren
 18.03.2021 20:13:11 Gast84572
NotSolved
18.03.2021 23:43:33 xlKing
NotSolved
19.03.2021 13:13:43 ZES
NotSolved
19.03.2021 15:59:32 xlKing
NotSolved
29.03.2021 06:11:32 ZES
NotSolved
29.03.2021 19:10:04 xlKing
NotSolved
29.03.2021 22:36:55 xlKing
NotSolved
30.03.2021 08:21:40 ZES
NotSolved