Sub
bolanalysis()
Dim
ws
As
Worksheet
Set
ws = Tabelle1
Dim
wsnew
As
Worksheet
Set
wsnew = Tabelle2
Dim
wsbol
As
Worksheet
Set
wsbol = Tabelle5
Dim
testrange
As
Range
Dim
lrow
As
Integer
Dim
Oldcell
As
Range
Dim
arrCriteria()
As
String
Dim
lngCriteriaCount
As
Long
Dim
element
As
Variant
Dim
arrCriterianew()
As
String
Dim
lngCriterianewCount
As
Long
Dim
lrownew
As
Integer
Dim
NewCell
As
Range
lngCriteriaCount = 3
ReDim
arrCriteria(0
To
lngCriteriaCount - 1)
arrCriteria(0) =
"Royalities_old"
arrCriteria(1) =
"Part#_old"
arrCriteria(2) =
"Description_old"
lngCriterianewCount = 3
ReDim
arrCriterianew(0
To
lngCriterianewCount - 1)
arrCriterianew(0) =
"Royalities_new"
arrCriterianew(1) =
"Part#_new"
arrCriterianew(2) =
"Description_new"
lrow = ws.UsedRange.SpecialCells(xlCellTypeLastCell).Row
lrownew = wsnew.UsedRange.SpecialCells(xlCellTypeLastCell).Row
lrowbol = wsbol.UsedRange.SpecialCells(xlCellTypeLastCell).Row
lcolbol = wsbol.UsedRange.SpecialCells(xlCellTypeLastCell).Column
Tabelle5.UsedRange.ClearContents
Tabelle5.UsedRange.ClearFormats
wsbol.Range(
"A1"
) =
"Part#_old"
wsbol.Range(
"B1"
) =
"Description_old"
wsbol.Range(
"C1"
) =
"Royalities_old"
wsbol.Range(
"E1"
) =
"Part#_new"
wsbol.Range(
"F1"
) =
"Description_new"
wsbol.Range(
"G1"
) =
"Royalities_new"
Errorhandler:
On
Error
GoTo
Errorhandler1
Tabelle2.Cells.Replace What:=
"Part#_new"
, Replacement:=
"Part#"
, SearchOrder:=xlByColumns, MatchCase:=
True
Tabelle2.Cells.Replace What:=
"Description_new"
, Replacement:=
"Description"
, SearchOrder:=xlByColumns, MatchCase:=
True
Tabelle2.Cells.Replace What:=
"Royalities_new"
, Replacement:=
"Royalities"
, SearchOrder:=xlByColumns, MatchCase:=
True
Tabelle1.Cells.Replace What:=
"Part#_old"
, Replacement:=
"Part#"
, SearchOrder:=xlByColumns, MatchCase:=
True
Tabelle1.Cells.Replace What:=
"Description_old"
, Replacement:=
"Description"
, SearchOrder:=xlByColumns, MatchCase:=
True
Tabelle1.Cells.Replace What:=
"Royalities_old"
, Replacement:=
"Royalities"
, SearchOrder:=xlByColumns, MatchCase:=
True
Errorhandler1:
Tabelle1.Cells.Replace What:=
"Part#"
, Replacement:=
"Part#_old"
, SearchOrder:=xlByColumns, MatchCase:=
True
, LookAt:=xlWhole
Tabelle1.Cells.Replace What:=
"Description"
, Replacement:=
"Description_old"
, SearchOrder:=xlByColumns, MatchCase:=
True
, LookAt:=xlWhole
Tabelle1.Cells.Replace What:=
"Royalities"
, Replacement:=
"Royalities_old"
, SearchOrder:=xlByColumns, MatchCase:=
True
, LookAt:=xlWhole
Tabelle2.Cells.Replace What:=
"Part#"
, Replacement:=
"Part#_new"
, SearchOrder:=xlByColumns, MatchCase:=
True
, LookAt:=xlWhole
Tabelle2.Cells.Replace What:=
"Description"
, Replacement:=
"Description_new"
, SearchOrder:=xlByColumns, MatchCase:=
True
, LookAt:=xlWhole
Tabelle2.Cells.Replace What:=
"Royalities"
, Replacement:=
"Royalities_new"
, SearchOrder:=xlByColumns, MatchCase:=
True
, LookAt:=xlWhole
If
ws.AutoFilterMode =
False
Then
ws.Rows(2).AutoFilter
End
If
If
wsnew.AutoFilterMode =
False
Then
wsnew.Rows(2).AutoFilter
End
If
For
i = 1
To
30
If
ws.Cells(2, i).Value =
"Royalities_old"
Then
ws.Range(ws.Cells(2, i), ws.Cells(lrow, i)).AutoFilter Field:=i, Criteria1:=
"<>0"
End
If
Next
For
i = 1
To
30
For
j = 1
To
10
For
Each
element
In
arrCriteria()
If
element = ws.Cells(2, i).Value
Then
If
element = wsbol.Cells(1, j).Value
Then
Set
testrange = ws.Range(ws.Cells(3, i), ws.Cells(lrow, i))
testrange.SpecialCells(xlCellTypeVisible).SpecialCells(xlCellTypeVisible).Copy wsbol.Cells(lrowbol + 1, j)
End
If
End
If
Next
Next
Next
For
i = 1
To
30
If
wsnew.Cells(2, i).Value =
"Royalities_new"
Then
wsnew.Range(wsnew.Cells(2, i), wsnew.Cells(lrownew, i)).AutoFilter Field:=i, Criteria1:=
"<>0"
End
If
Next
For
i = 1
To
30
For
j = 1
To
10
For
Each
element
In
arrCriterianew()
If
element = wsnew.Cells(2, i).Value
Then
If
element = wsbol.Cells(1, j).Value
Then
wsnew.Range(wsnew.Cells(3, i), wsnew.Cells(lrownew, i)).SpecialCells(xlCellTypeVisible).Copy wsbol.Cells(lrowbol + 1, j)
End
If
End
If
Next
Next
Next
wsbol.Range(
"I1"
).FormulaLocal =
"=SUMME(H3:H20)"
End
Sub