Sub
loeschen()
Dim
wb
As
Workbook
Set
wb = ActiveWorkbook
Dim
ws
As
Worksheet
Set
ws = Tabelle1
Dim
ws2
As
Worksheet
Set
ws2 = Tabelle2
Dim
wb2
As
Workbook
Tabelle1.UsedRange.ClearContents
Tabelle1.UsedRange.ClearContents
Tabelle1.UsedRange.ClearFormats
Tabelle1.UsedRange.ClearFormats
On
Error
Resume
Next
Tabelle2.ShowAllData
Tabelle2.UsedRange.Copy ws.Cells(1, 1)
Tabelle2.UsedRange.ClearContents
Tabelle2.UsedRange.ClearContents
Tabelle2.UsedRange.ClearFormats
Tabelle2.UsedRange.ClearFormats
For
i = 1
To
12
If
ws.Cells(2, i) =
"Part#_new"
Then
Tabelle1.Cells.Replace What:=
"Part#_new"
, Replacement:=
"Part#"
, SearchOrder:=xlByColumns, MatchCase:=
True
Tabelle1.Cells.Replace What:=
"Description_new"
, Replacement:=
"Description"
, SearchOrder:=xlByColumns, MatchCase:=
True
Tabelle1.Cells.Replace What:=
"Royalities_new"
, Replacement:=
"Royalities"
, SearchOrder:=xlByColumns, MatchCase:=
True
End
If
Next
Dim
myfilenamepicker
As
FileDialog
Set
myfilenamepicker = Application.FileDialog(msoFileDialogFilePicker)
myfilenamepicker.InitialFileName =
"G:\Departments\Reporting Analyzing\_Downloads"
myfilenamepicker.Show
If
myfilenamepicker.SelectedItems.Count <> 0
Then
myfilename = myfilenamepicker.SelectedItems(1)
Set
wb2 = ThisWorkbook.Application.Workbooks.Open(myfilename)
Debug.Print (myfilename)
Dim
ws3
As
Worksheet
Set
ws3 = wb2.Worksheets(TabellenIndex(wb2,
"Tabelle1"
))
On
Error
Resume
Next
ws3.ShowAllData
ws3.UsedRange.Copy ws2.Cells(1, 1)
Debug.Print (ws3.Name)
End
If
wb2.Close SaveChanges:=
False
Call
kopiereneinfügengundh
Call
in_analysis_bom_pasten
End
Sub
Function
TabellenIndex(
ByRef
wkb
As
Workbook,
ByVal
strCodename
As
String
)
As
Integer
Dim
wks
As
Worksheet
For
Each
wks
In
wkb.Worksheets
If
wks.CodeName = strCodename
Then
TabellenIndex = wks.Index
Exit
Function
End
If
Next
wks
End
Function
Sub
kopiereneinfügengundh()
Dim
ws
As
Worksheet
Set
ws = Tabelle1
Dim
wsnew
As
Worksheet
Set
wsnew = Tabelle2
Dim
lrow
As
Integer
Dim
Oldcell
As
Range
Dim
arrCriteria()
As
String
Dim
lngCriteriaCount
As
Long
Dim
element
As
Variant
Dim
lrownew
As
Integer
Dim
NewCell
As
Range
lngCriteriaCount = 2
ReDim
arrCriteria(0
To
lngCriteriaCount - 1)
arrCriteria(0) =
"Description"
arrCriteria(1) =
"Part#"
Tabelle4.UsedRange.ClearContents
Tabelle4.UsedRange.ClearFormats
lrow = ws.UsedRange.SpecialCells(xlCellTypeLastCell).Row
lrownew = wsnew.UsedRange.SpecialCells(xlCellTypeLastCell).Row
lrowpaste = Tabelle1.UsedRange.SpecialCells(xlCellTypeLastCell).Row
Debug.Print (lrowpaste)
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 =
"Typ"
Then
ws.Range(ws.Cells(2, i), ws.Cells(lrow, i)).AutoFilter Field:=i, Criteria1:=
"KT"
End
If
Next
For
i = 1
To
30
If
ws.Cells(2, i).Value =
"Quantity"
Then
ws.Range(ws.Cells(2, i), ws.Cells(lrow, i)).AutoFilter Field:=i, Criteria1:=
"<>0"
End
If
Next
For
i = 1
To
30
If
wsnew.Cells(2, i).Value =
"Typ"
Then
wsnew.Range(wsnew.Cells(2, i), wsnew.Cells(lrow, i)).AutoFilter Field:=i, Criteria1:=
"KT"
End
If
Next
For
i = 1
To
30
If
wsnew.Cells(2, i).Value =
"Quantity"
Then
wsnew.Range(wsnew.Cells(2, i), wsnew.Cells(lrow, i)).AutoFilter Field:=i, Criteria1:=
"<>0"
End
If
Next
For
i = 1
To
10
Set
Oldcell = ws.Cells(2, i)
For
Each
element
In
arrCriteria()
If
element = ws.Cells(2, i).Value
Then
ws.Range(ws.Cells(2, i), ws.Cells(lrow, i)).SpecialCells(xlCellTypeVisible).Copy Tabelle4.Cells(1, i)
End
If
Next
Next
For
i = 1
To
10
Set
NewCell = wsnew.Cells(2, i)
For
Each
element
In
arrCriteria()
If
element = wsnew.Cells(2, i).Value
Then
wsnew.Range(wsnew.Cells(3, i), wsnew.Cells(lrownew, i)).SpecialCells(xlCellTypeVisible).Copy Tabelle4.Cells(lrowpaste, i)
End
If
Next
Next
lrow4 = Tabelle4.UsedRange.SpecialCells(xlCellTypeLastCell).Row
Tabelle4.Range(Tabelle4.Cells(1, 6), Tabelle4.Cells(lrow4, 7)).RemoveDuplicates Columns:=2, Header:=xlYes
End
Sub
Sub
in_analysis_bom_pasten()
Dim
ws1
As
Worksheet
Set
ws1 = Tabelle4
Dim
wsanalysis
As
Worksheet
Set
wsanalysis = Tabelle3
Dim
lrow
As
Integer
Dim
arrCriteria()
As
String
Dim
lngCriteriaCount
As
Long
lngCriteriaCount = 3
ReDim
arrCriteria(0
To
lngCriteriaCount - 1)
arrCriteria(0) =
"Category"
arrCriteria(1) =
"Part#"
arrCriteria(2) =
"Description"
If
Tabelle3.AutoFilterMode =
True
Then
On
Error
GoTo
Errorhandler:
Tabelle3.ShowAllData
End
If
Errorhandler:
lrow1 = wsanalysis.UsedRange.SpecialCells(xlCellTypeLastCell).Row
For
i = 1
To
30
For
Each
element
In
arrCriteria()
If
wsanalysis.Cells(17, i) = element
Then
wsanalysis.Range(wsanalysis.Cells(18, i), wsanalysis.Cells(lrow1, i)).Clear
End
If
Next
Next
For
i = 1
To
30
For
j = 1
To
10
If
wsanalysis.Cells(17, j) = ws1.Cells(1, i).Value
Then
ws1.Range(ws1.Cells(2, i), ws1.Cells(lrow1, i)).SpecialCells(xlCellTypeVisible).Copy wsanalysis.Cells(18, j)
End
If
Next
Next
End
Sub