Microsoft Excel

Herbers Excel/VBA-Archiv

Informationen und Beispiele zum Thema MsgBox
BildScreenshot zu MsgBox MsgBox-Seite mit Beispielarbeitsmappe aufrufen

summewenn Fkt. als Makro | Herbers Excel-Forum


Betrifft: summewenn Fkt. als Makro von: meixner
Geschrieben am: 29.11.2009 16:17:30

Hallo zusammen,

habe ein Problem mit einem Makro. Anhand eines Makros wird eine Tabelle kopiert mit range(AX :BA) und in eine andere Excel - Mappe kopiert. Ich möchte, aber das dieses Makro gleichzeitig vor kopieren eine summewenn - Funktion ausführt.
Die Fkt. heisst: summewenn(AX:AX; AX8; BA:BA), damit manche Daten nicht doppelt vorkommen.
Bsp. Tabelle die in die andere Excelmappe kopiert werden soll:

Spalte AX Spalte AY Spalte BA Spalte BB
28 S 576 15542
29 S 5.610 5610
8 S 954 1717
28 S 8.312 15542
2 S 136.940 136940
8 S 763 1717
25 S 5.058 5058
28 S 6.654 15542
Das Problem ist, das die Nr. 28 hier 3x vorkommt. Deshalb soll das Makro für die Nr. 28 anhand eines Makros die Zahlen in spalte BB zusammenfassen und als eine Zeile in die neue Excel - Arbeitsmappe eintragen.

In die neue Arbeitsmappe soll nicht die 3x mal die Zeile 28 vorkommen, sondern nur einmal und dafür aber zusammengezählt die Zahlen aus Spalte BB.

Spalte AX Spalte AY Spalte BA
28 S 576
28 S 8.312
28 S 6.654

In der neuen Excel - Mappe soll nur noch

Spalte AX Spalte AY Spalte BA
28 S 15.542

auftauchen.

Kann mir jmd. dabei helfen dies zusammenzufassen. Wie kann ich eine Summewenn - fkt. als Makro schreiben und das so formulieren, das z.B. die Zeile mit Nr. 28 nur einmal auftaucht. Unten das Makro.

Vielen Dank
Dani.

Sub ordersheet_erstellen()

Dim wbReweighting As Workbook
Dim wsReweighting As Worksheet
Dim wbParameter As Workbook
Dim wsParameter As Worksheet
Dim wbOrdersheet As Workbook                                                   'das neue Excel  _
Sheet als Workbook definieren
Dim wsOrdersheet As Worksheet                                                  'das Ziel- _
Arbeitsblatt als Arbeitsblatt definieren
Dim nameTemplate As String                                                     'Name Template  _
als String definieren
Dim nameOrdersheet As String                                                   'Name fertiges  _
Ordersheet as String definieren
Dim letztevolleZeile As Long

Application.ScreenUpdating = False

Dim NameDatei As String
Dim zu_kopierenden_Bereich As String
NameDatei = ThisWorkbook.Name
zu_kopierenden_Bereich = "Ax11:ba"


Set wbReweighting = Application.Workbooks("Template_alle_Kapitalmaßnahmen.xls")
Set wsReweighting = wbReweighting.Worksheets(1)
Set wbParameter = Application.Workbooks("Template_alle_Kapitalmaßnahmen.xls")
Set wsParameter = wbReweighting.Worksheets("Parameter")
nameTemplate = wsParameter.Cells(74, 2).Value                                   'liest Namen  _
des zu öffnenden Template aus Zelle 4,2 des Arbeitsblatt "Parameter"
nameOrdersheet = wsParameter.Cells(75, 2).Value                                 'liest Names  _
des fertigen Ordersheets aus Zelle 5,2 des Arbeitsblatt "Parameter"
letztevolleZeile = wsReweighting.Cells(Rows.Count, 1).End(xlUp).Row            'sucht letzte  _
volle Zeile in Spalte 2

If MsgBox("Hast Du vor Erstellung des Anteilebelege per Reuters Real Time alle Kurse  _
aktualisiert?", vbOKCancel, "Warnung") = vbCancel Then
    Exit Sub
End If

Set wbOrdersheet = Application.Workbooks.Open(nameTemplate)                    'Order Template ö _
ffnen
Set wsOrdersheet = wbOrdersheet.Worksheets(1)                                  '1. Arbeitsblatt  _
des neuen Excel Sheet als Ziel Arbeitsblatt bestimmen


wsReweighting.Range(zu_kopierenden_Bereich & letztevolleZeile).Copy            'zu kopierenden  _
Bereich definieren und kopieren

wsOrdersheet.Range("a13").Activate                                             'Ordersheet  _
aktivieren & bestimmen, ab wo Daten eingefügt werden
Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:= _
    xlNone, SkipBlanks:=False, Transpose:=False                                'zu kopierenden  _
Bereich mit "paste special" einfügen

wsOrdersheet.Range("B4").Value = wsParameter.Range("B85").Value                 'Name Fonds in  _
Ordersheet schreiben
wsOrdersheet.Range("e13:e100").Value = wsParameter.Range("B85").Value                '"Created"  _
in Ordersheet schreiben
wsOrdersheet.Range("f13:f100").Value = wsParameter.Range("B86").Value         'Valuta in  _
Ordersheet schreiben
wsOrdersheet.Range("c13:c100").Value = wsOrdersheet.Range("f4").Value

'Im Ticket werden die Daten sortiert, überflüssige Werte werden entfernt.
wsOrdersheet.Range("A13:h100").Select                                         'Gesamtbereich  _
wird markiert
    
Selection.Sort Key1:=Range("a13"), Order1:=xlDescending, Key2:=Range("h13" _
        ), Order2:=xlAscending, Header:=xlNo, OrderCustom:=1, MatchCase:=False _
        , Orientation:=xlTopToBottom, DataOption1:=xlSortNormal, DataOption2:= _
        xlSortNormal                                                           'Sortieren nach  _
Spalte e, dann Spalte B
        
Rows(wsParameter.Cells(82, 2).Value).Select                                    'Löschbereich ( _
siehe Parameter) wird gelöscht
Selection.Delete Shift:=xlUp
         
wsOrdersheet.Range("a1").Activate                                              'Zelle A1  _
aktivieren, damit gelöschter Bereich nicht mehr markiert ist

wbOrdersheet.SaveAs nameOrdersheet                                             'Ordersheet wird  _
abgespeichert
        
wbOrdersheet.Close                                                             'Ordersheet wird  _
geschlossen

Application.ScreenUpdating = True                                              'aktiviert  _
Bildschirmaktualisierung

End Sub

  

Betrifft: AW: summewenn Fkt. als Makro von: Josef Ehrensberger
Geschrieben am: 29.11.2009 17:32:32

Hallo Dani,

probier mal.

' **********************************************************************
' Modul: Modul1 Typ: Allgemeines Modul
' **********************************************************************

Option Explicit

Sub copySum()
  Dim objSh As Worksheet
  Dim lngRow As Long, lngLast As Long, lngNext As Long
  
  lngNext = 2
  
  Set objSh = Sheets("Tabelle2") 'Zieltabelle
  
  With Sheets("Tabelle3") 'Quelltabelle
    lngLast = Application.Max(2, .Cells(Rows.Count, 51).End(xlUp).Row)
    .Columns(54).Insert
    .Range("BB2").Formula = "=IF(COUNTIF($AY$2:$AY2,AY2)=1,SUMIF($AY$2:$AY$" & _
      CStr(lngLast) & ",AY2,$BA$2:$BA$" & CStr(lngLast) & "),"""")"
    .Range("BB2:BB" & CStr(lngLast)).FillDown
    objSh.Range("AY2:BA" & Rows.Count).Clear
    For lngRow = 2 To lngLast
      If .Cells(lngRow, 54) <> "" Then
        objSh.Cells(lngNext, 51) = .Cells(lngRow, 51)
        objSh.Cells(lngNext, 52) = .Cells(lngRow, 52)
        objSh.Cells(lngNext, 53) = .Cells(lngRow, 54)
        lngNext = lngNext + 1
      End If
    Next
    .Columns(54).Delete
  End With
  
End Sub



Gruß Sepp



Beiträge aus den Excel-Beispielen zum Thema "summewenn Fkt. als Makro"