Microsoft Excel

Herbers Excel/VBA-Archiv

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


Betrifft: VBA Zwischensumme einfügen kombiniert mit Links von: Julia
Geschrieben am: 31.01.2010 20:32:30

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

  

Betrifft: AW: VBA Zwischensumme einfügen kombiniert mit Links von: Josef Ehrensberger
Geschrieben am: 31.01.2010 22:27:59

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



  

Betrifft: AW: VBA Zwischensumme einfügen kombiniert mit Links von: Julia
Geschrieben am: 01.02.2010 00:06:16

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


  

Betrifft: AW: VBA Zwischensumme einfügen kombiniert mit Links von: Josef Ehrensberger
Geschrieben am: 01.02.2010 07:41:08

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



Beiträge aus den Excel-Beispielen zum Thema "VBA Zwischensumme einfügen kombiniert mit Links"