Live-Forum - Die aktuellen Beiträge
Datum
Titel
28.03.2024 21:12:36
28.03.2024 18:31:49
Anzeige
Archiv - Navigation
1132to1136
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

VBA Zwischensumme einfügen kombiniert mit Links | Herbers Excel-Forum

VBA Zwischensumme einfügen kombiniert mit Links
31.01.2010 20:32:30
Julia

Hallo zusammen.
ich habe folgendes Problem, für das ich ein Makro haben möchte:
In Spalte A habe ich von Zeile 3 bis 9 verschiedene Kriterien, die über einen Zeitablauf
(Zeile 2, Spalte B bis M) verschiedene Werte tragen können.
Dynamisch halte ich den Zeitablauf und die Kriterien mit variablen, die ich mit EndXlup, EndXlDown,
EndXlRight etc definiere.
Aber wie kriege ich es hin, dass
1. die Kriterien durchsucht werden, und dort wo Links bis zur dritten Stelle "ABC" steht in der Zeile unter dem letzten Suchtreffer eine Leerzeile eingefügt wird
2. eine Zwischensumme über alle Links bis zur dritten Stelle "ABC" hart eingefügt wird und
3. Die Zeilen aller vorherigen Suchtreffer "ABC" gelöscht werden.
Am besten schaut Euch das Beispiel an, dann wird verständlich, was gemeint ist.
https://www.herber.de/bbs/user/67665.xls
Bin für jede Hilfe dankbar,
Liebe Grüße,
Julia

3
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: VBA Zwischensumme einfügen kombiniert mit Links
31.01.2010 22:27:59
Josef Ehrensberger
Hallo Julia,
' **********************************************************************
' Modul: Modul6 Typ: Allgemeines Modul
' **********************************************************************

Option Explicit

Sub abc()
  Dim rngDel As Range
  Dim lngRow As Long, lngCol As Long, lngLast As Long, lngR As Long, lngC As Long
  
  With ActiveSheet
    lngLast = Application.Max(3, .Cells(Rows.Count, 1).End(xlUp).Row)
    lngCol = .Cells(3, .Columns.Count).End(xlToLeft).Column
    lngRow = 3
    Do
      lngR = lngRow + 1
      If UCase(Left(.Cells(lngRow, 1), 3)) = "ABC" Then
        Do While UCase(Left(.Cells(lngR, 1), 3)) = "ABC"
          lngR = lngR + 1
        Loop
        For lngC = 2 To lngCol
          .Cells(lngR - 1, lngC) = Application.Sum(.Range(.Cells(lngRow, lngC), _
            .Cells(lngR - 1, lngC)))
        Next
        If rngDel Is Nothing Then
          Set rngDel = .Range(.Cells(lngRow, 1), .Cells(lngR - 2, lngCol))
        Else
          Set rngDel = Union(rngDel, .Range(.Cells(lngRow, 1), .Cells(lngR - 2, _
            lngCol)))
        End If
        lngRow = lngR - 1
      End If
      lngRow = lngRow + 1
    Loop While lngRow <= lngLast
  End With
  
  If Not rngDel Is Nothing Then rngDel.Delete xlUp
  
  Set rngDel = Nothing
End Sub

Gruß Sepp
Anzeige
AW: VBA Zwischensumme einfügen kombiniert mit Links
01.02.2010 00:06:16
Julia
Super, Sepp!
Vielen Dank. Einzige Rückfrage noch: Wie kann der Quellcode umgeändert werden, dass als Zwischensummenbezeichner einfach "ABC" statt "ABC 4" geschrieben wird?
Julia
AW: VBA Zwischensumme einfügen kombiniert mit Links
01.02.2010 07:41:08
Josef Ehrensberger
Hallo Julia,

hab ich eingebaut. Du kannst den Begriff der gesucht wird jetzt einfach anpassen, siehe Kommentar.

Sub abc()
  Dim rngDel As Range
  Dim lngRow As Long, lngCol As Long, lngLast As Long, lngR As Long, lngC As Long
  Dim strFind As String
  
  strFind = "ABC" 'Gesuchter Begriff - Anpassen!
  
  strFind = UCase(strFind)
  
  With ActiveSheet
    lngLast = Application.Max(3, .Cells(Rows.Count, 1).End(xlUp).Row)
    lngCol = .Cells(3, .Columns.Count).End(xlToLeft).Column
    lngRow = 3
    Do
      lngR = lngRow + 1
      If UCase(Left(.Cells(lngRow, 1), Len(strFind))) = strFind Then
        Do While UCase(Left(.Cells(lngR, 1), Len(strFind))) = strFind
          lngR = lngR + 1
        Loop
        .Cells(lngR - 1, 1) = strFind
        For lngC = 2 To lngCol
          .Cells(lngR - 1, lngC) = Application.Sum(.Range(.Cells(lngRow, lngC), _
            .Cells(lngR - 1, lngC)))
        Next
        If rngDel Is Nothing Then
          Set rngDel = .Range(.Cells(lngRow, 1), .Cells(lngR - 2, lngCol))
        Else
          Set rngDel = Union(rngDel, .Range(.Cells(lngRow, 1), .Cells(lngR - 2, _
            lngCol)))
        End If
        lngRow = lngR - 1
      End If
      lngRow = lngRow + 1
    Loop While lngRow <= lngLast
  End With
  
  If Not rngDel Is Nothing Then rngDel.Delete xlUp
  
  Set rngDel = Nothing
End Sub

Gruß Sepp
Anzeige

305 Forumthreads zu ähnlichen Themen

Anzeige
Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige