AW: in deiner Liste ist ganz unten noch eine Tabelle
27.10.2014 17:24:39
Tino
Hallo,
ges. Code wieder ersetzen!
Option Explicit
Sub Daten_Verarbeiten(WBQuelle As Worksheet, WBZiel As Worksheet)
Dim ArData
Dim nMinRow, MaxRow&, n&
Dim oDic As Object, ODicBrutto As Object, oDicGes As Object
Const Suchwort$ = "Artikelnum"
Const OffsetTabAnfang& = -1
On Error GoTo ErrorHandler:
With Tabelle1
nMinRow = Application.Match(Suchwort & "*", .Columns(1), 0)
nMinRow = nMinRow + OffsetTabAnfang
MaxRow = .Cells(.Rows.Count, 1).End(xlUp).Row
ArData = .Range(.Cells(nMinRow, 1), .Cells(MaxRow, 4))
End With
'nMinRow = 16
With Tabelle2
.Range("A16", .Cells(.Rows.Count, 4)).Clear
For n = 1 To Ubound(ArData) + OffsetTabAnfang
If InStr(ArData(n - OffsetTabAnfang, 1), Suchwort) > 0 Or (n = Ubound(ArData) + OffsetTabAnfang) Then
If Not oDic Is Nothing Then
If oDic.Count > 0 Then
With .Cells(nMinRow, 1).Resize(oDic.Count).Resize(, 4)
.Columns(1).NumberFormat = "0"
.Columns(1).Value = Application.Transpose(oDic.keys)
.Columns(2).Value = Application.Transpose(oDic.items)
.Columns(3).NumberFormat = "#,##0.00 $"
.Columns(3).Value = Application.Transpose(ODicBrutto.items)
.Columns(4).NumberFormat = "#,##0.00 $"
.Columns(4).Value = Application.Transpose(oDicGes.items)
With .Rows(2).Resize(.Rows.Count)
.Sort Key1:=.Cells(1, 1), Order1:=xlAscending, Header:=xlYes
nMinRow = .Rows(.Rows.Count).Row + 1
End With
With .Rows(1).Resize(2)
.Font.Bold = True
.Font.Size = 12
.Rows(2).Interior.Color = RGB(192, 192, 192)
End With
End With
End If
End If
Set oDic = Nothing
Set oDic = CreateObject("Scripting.Dictionary")
Set ODicBrutto = Nothing
Set ODicBrutto = CreateObject("Scripting.Dictionary")
Set oDicGes = Nothing
Set oDicGes = CreateObject("Scripting.Dictionary")
End If
If IsNumeric(ArData(n, 2)) And ArData(n, 2) <> "" Then
oDic(ArData(n, 1)) = oDic(ArData(n, 1)) + IIf(IsError(ArData(n, 2)), 0, ArData(n, 2))
ODicBrutto(ArData(n, 1)) = ODicBrutto(ArData(n, 1)) + IIf(IsError(ArData(n, 3)), 0, ArData(n, 3))
oDicGes(ArData(n, 1)) = oDicGes(ArData(n, 1)) + IIf(IsError(ArData(n, 4)), 0, ArData(n, 4))
Else
oDic(ArData(n, 1)) = IIf(IsError(ArData(n, 2)), 0, ArData(n, 2))
ODicBrutto(ArData(n, 1)) = IIf(IsError(ArData(n, 3)), 0, ArData(n, 3))
oDicGes(ArData(n, 1)) = IIf(IsError(ArData(n, 4)), 0, ArData(n, 4))
End If
Next n
End With
Exit Sub
ErrorHandler:
MsgBox Err.Description, _
vbCritical + vbMsgBoxSetForeground + vbMsgBoxHelpButton, _
"Error: " & Err.Number, Err.HelpFile, Err.HelpContext
End Sub
Gruß Tino