AW: RECHERCHE, Statusanzeige eingeben..... oT
19.03.2015 18:13:17
Sandra
Hallo,
ihr braucht euch nie entschuldigen. Bin froh das es diesen Forum gibt :-)
Anbei mein Code:
Der ist aber Mega Lang:-)
Sub freieLagerplätze()
ChDir "C:\Users\sandra\Desktop"
Workbooks.OpenText Filename:= _
"C:\Users\Sandra\Desktop\freie Lagerplätze WH25.txt", Origin:=xlWindows, _
StartRow:=7, DataType:=xlFixedWidth, FieldInfo:=Array(Array(0, 1), Array(30 _
, 1)), TrailingMinusNumbers:=True
Columns("A:B").Select
Selection.Copy
Windows("Anzahl freie Lagerplätze.xls").Activate
Range("A1").Select
ActiveSheet.Paste
Range("F33").Select
Application.CutCopyMode = False
Workbooks.OpenText Filename:= _
"C:\Users\Sandra\Desktop\freie Lagerplätze GD65.txt", Origin:=xlWindows, _
StartRow:=7, DataType:=xlDelimited, TextQualifier:=xlDoubleQuote, _
ConsecutiveDelimiter:=False, Tab:=True, Semicolon:=True, Comma:=False, _
Space:=False, Other:=True, OtherChar:="|", FieldInfo:=Array(Array(1, 1), _
Array(2, 1), Array(3, 1), Array(4, 1), Array(5, 1)), TrailingMinusNumbers:=True
Columns("C:C").EntireColumn.AutoFit
Columns("A:C").Select
Selection.Copy
Windows("Anzahl freie Lagerplätze.xls").Activate
Sheets("Tabelle2").Select
ActiveSheet.Paste
Range("D19").Select
Sheets("Tabelle1").Select
Sheets("Tabelle3").Select
ChDir "G:\Transfer\Allgemein\WE"
Workbooks.Open Filename:= _
"G:\Transfer\Allgemein\WE\Makro frei Lagerplätze.xls", Origin:=xlWindows
Sheets("RB umwandeln").Select
Columns("A:B").Select
Range("A96").Activate
Selection.Copy
Windows("Anzahl freie Lagerplätze.xls").Activate
Range("A1").Select
ActiveSheet.Paste
Application.CutCopyMode = False
Workbooks.Open Filename:= _
"G:\Transfer\Allgemein\WE\Makro frei Lagerplätze.xls"
Sheets("belegte Lagerplätze").Select
Columns("A:B").Select
Range("A215").Activate
Selection.Copy
Windows("Anzahl freie Lagerplätze.xls").Activate
Sheets("Tabelle4").Select
Range("A1").Select
ActiveSheet.Paste
Range("H24").Select
Application.CutCopyMode = False
Sheets("Tabelle5").Select
Range("A1").Select
Sheets("Tabelle2").Select
Columns("B:B").Select
Selection.Delete Shift:=xlToLeft
Range("C7").Select
Application.Run "PERSONAL.xlsm!freieLagerplätze1"
Sheets("Tabelle1").Select
Rows("1:2").Select
Range("A2").Activate
Selection.Delete Shift:=xlUp
Rows("1:1").Select
Selection.Insert Shift:=xlDown
Range("D8").Select
Application.Run "PERSONAL.xlsm!freieLagerplätze2"
Columns("A:B").Select
Selection.Sort Key1:=Range("A1"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
ActiveWindow.SmallScroll Down:=114
ActiveWindow.ScrollRow = 128
ActiveWindow.ScrollRow = 132
ActiveWindow.ScrollRow = 133
ActiveWindow.ScrollRow = 136
ActiveWindow.ScrollRow = 140
ActiveWindow.ScrollRow = 143
ActiveWindow.ScrollRow = 144
ActiveWindow.ScrollRow = 148
ActiveWindow.ScrollRow = 150
ActiveWindow.ScrollRow = 153
ActiveWindow.ScrollRow = 156
ActiveWindow.ScrollRow = 158
ActiveWindow.ScrollRow = 160
ActiveWindow.ScrollRow = 162
ActiveWindow.ScrollRow = 163
ActiveWindow.ScrollRow = 165
ActiveWindow.ScrollRow = 166
ActiveWindow.ScrollRow = 167
ActiveWindow.ScrollRow = 169
ActiveWindow.ScrollRow = 172
ActiveWindow.ScrollRow = 175
ActiveWindow.ScrollRow = 179
ActiveWindow.ScrollRow = 181
ActiveWindow.ScrollRow = 182
ActiveWindow.ScrollRow = 184
ActiveWindow.ScrollRow = 185
ActiveWindow.ScrollRow = 188
ActiveWindow.ScrollRow = 191
ActiveWindow.ScrollRow = 192
ActiveWindow.ScrollRow = 194
ActiveWindow.ScrollRow = 197
ActiveWindow.ScrollRow = 198
ActiveWindow.ScrollRow = 201
ActiveWindow.ScrollRow = 202
ActiveWindow.ScrollRow = 203
ActiveWindow.ScrollRow = 204
ActiveWindow.ScrollRow = 203
ActiveWindow.ScrollRow = 198
ActiveWindow.ScrollRow = 192
ActiveWindow.ScrollRow = 189
ActiveWindow.ScrollRow = 182
ActiveWindow.ScrollRow = 177
ActiveWindow.ScrollRow = 171
ActiveWindow.ScrollRow = 164
ActiveWindow.ScrollRow = 159
ActiveWindow.ScrollRow = 153
ActiveWindow.ScrollRow = 145
ActiveWindow.ScrollRow = 140
ActiveWindow.ScrollRow = 133
ActiveWindow.ScrollRow = 126
ActiveWindow.ScrollRow = 119
ActiveWindow.ScrollRow = 116
ActiveWindow.ScrollRow = 109
ActiveWindow.ScrollRow = 104
ActiveWindow.ScrollRow = 100
ActiveWindow.ScrollRow = 95
ActiveWindow.ScrollRow = 91
ActiveWindow.ScrollRow = 90
ActiveWindow.ScrollRow = 87
ActiveWindow.ScrollRow = 84
ActiveWindow.ScrollRow = 83
ActiveWindow.ScrollRow = 79
ActiveWindow.ScrollRow = 76
ActiveWindow.ScrollRow = 73
ActiveWindow.ScrollRow = 70
ActiveWindow.ScrollRow = 67
ActiveWindow.ScrollRow = 64
ActiveWindow.ScrollRow = 63
ActiveWindow.ScrollRow = 60
ActiveWindow.ScrollRow = 59
ActiveWindow.ScrollRow = 58
ActiveWindow.ScrollRow = 57
ActiveWindow.ScrollRow = 56
ActiveWindow.ScrollRow = 55
ActiveWindow.ScrollRow = 54
ActiveWindow.ScrollRow = 52
ActiveWindow.ScrollRow = 50
ActiveWindow.ScrollRow = 47
ActiveWindow.ScrollRow = 45
ActiveWindow.ScrollRow = 43
ActiveWindow.ScrollRow = 41
ActiveWindow.ScrollRow = 40
ActiveWindow.ScrollRow = 37
ActiveWindow.ScrollRow = 36
ActiveWindow.ScrollRow = 34
ActiveWindow.ScrollRow = 32
ActiveWindow.ScrollRow = 31
ActiveWindow.ScrollRow = 29
ActiveWindow.ScrollRow = 28
ActiveWindow.ScrollRow = 27
ActiveWindow.ScrollRow = 26
ActiveWindow.ScrollRow = 25
ActiveWindow.ScrollRow = 24
ActiveWindow.ScrollRow = 23
ActiveWindow.ScrollRow = 22
ActiveWindow.ScrollRow = 19
ActiveWindow.ScrollRow = 18
ActiveWindow.ScrollRow = 17
ActiveWindow.ScrollRow = 16
ActiveWindow.ScrollRow = 15
ActiveWindow.ScrollRow = 14
ActiveWindow.ScrollRow = 13
ActiveWindow.ScrollRow = 12
ActiveWindow.ScrollRow = 11
ActiveWindow.ScrollRow = 10
ActiveWindow.ScrollRow = 9
ActiveWindow.ScrollRow = 8
ActiveWindow.ScrollRow = 7
ActiveWindow.ScrollRow = 6
ActiveWindow.ScrollRow = 5
ActiveWindow.ScrollRow = 4
ActiveWindow.ScrollRow = 3
ActiveWindow.ScrollRow = 2
ActiveWindow.ScrollRow = 1
Rows("1:1").Select
Selection.Insert Shift:=xlDown
Range("D9").Select
Application.Run "PERSONAL.xlsm!freieLagerplätze3"
Sheets("Tabelle1").Select
Application.Run "PERSONAL.xlsm!freieLagerplätze4"
ActiveWindow.SmallScroll Down:=-15
Range("D10").Select
Columns("A:B").Select
Selection.Sort Key1:=Range("B1"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
With Selection.Font
.Name = "Arial"
.Size = 12
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = xlAutomatic
End With
Selection.Font.Bold = True
Columns("A:B").EntireColumn.AutoFit
Rows("1:1").Select
Selection.Insert Shift:=xlDown
Range("A1").Select
ActiveCell.FormulaR1C1 = "Lagerplatz"
Range("B1").Select
ActiveCell.FormulaR1C1 = "Feldtyp"
Range("A1:B1").Select
With Selection.Interior
.ColorIndex = 6
.Pattern = xlSolid
End With
Columns("A:B").Select
Range("B1").Activate
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlInsideVertical)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
Selection.Subtotal GroupBy:=2, Function:=xlCount, TotalList:=Array(2), _
Replace:=True, PageBreaks:=False, SummaryBelowData:=True
ActiveSheet.Outline.ShowLevels RowLevels:=3
ActiveSheet.Outline.ShowLevels RowLevels:=2
Columns("A:B").EntireColumn.AutoFit
Columns("B:B").Select
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Columns("B:B").Select
Selection.Font.ColorIndex = 3
Range("B1").Select
Selection.Font.ColorIndex = 0
Range("B1").Select
End Sub
Sub freieLagerplätze1()
Dim loletzte As Long
Dim loA As Long
Dim dblSum As Double
Dim DblMitt As Double
loletzte = Cells(Rows.Count, 1).End(xlUp).Row
Application.ScreenUpdating = False
Application.EnableEvents = False
For loA = loletzte To 2 Step -1
If Application.WorksheetFunction.CountIf(Range(Cells(2, 1), Cells(loA, 1)), Cells(loA, 1)) > _
1 Then Rows(loA).Delete Shift:=xlUp
Next
End Sub
Sub freieLagerplätze3()
Dim loLetzte1 As Long
Dim loLetzte2 As Long
Dim i As Long, j As Long
Dim raA As Range
Dim wksA As Worksheet
Dim wksB As Worksheet
Set wksA = Sheets("Tabelle1") ' Tabellennamen anpassen; Tabelle in der gelöscht wird
Set wksB = Sheets("Tabelle2") ' Tabellennamen anpassen; Tabelle in der die Werte in Spalte _
A gelistet sind
With wksB
loLetzte2 = IIf(IsEmpty(.Cells(.Rows.Count, 1)), .Cells(.Rows.Count, 1).End(xlUp).Row, . _
Rows.Count)
End With
With wksA
loLetzte1 = IIf(IsEmpty(.Cells(.Rows.Count, 1)), .Cells(.Rows.Count, 1).End(xlUp).Row, . _
Rows.Count)
For i = 2 To loLetzte1
For j = 2 To loLetzte2
If Trim(.Cells(i, 1)) = Trim(wksB.Cells(j, 1)) Then
If raA Is Nothing Then
Set raA = Rows(i)
Else
Set raA = Union(raA, Rows(i))
End If
End If
Next j
Next i
End With
If Not raA Is Nothing Then
raA.Delete
Set raA = Nothing
End If
End Sub
Sub freieLagerplätze4()
Dim loLetzte1 As Long
Dim loLetzte2 As Long
Dim i As Long, j As Long
Dim raA As Range
Dim wksA As Worksheet
Dim wksB As Worksheet
Set wksA = Sheets("Tabelle1") ' Tabellennamen anpassen; Tabelle in der gelöscht wird
Set wksB = Sheets("Tabelle4") ' Tabellennamen anpassen; Tabelle in der die Werte in Spalte _
A gelistet sind
With wksB
loLetzte2 = IIf(IsEmpty(.Cells(.Rows.Count, 1)), .Cells(.Rows.Count, 1).End(xlUp).Row, . _
Rows.Count)
End With
With wksA
loLetzte1 = IIf(IsEmpty(.Cells(.Rows.Count, 1)), .Cells(.Rows.Count, 1).End(xlUp).Row, . _
Rows.Count)
For i = 2 To loLetzte1
For j = 2 To loLetzte2
If Trim(.Cells(i, 1)) = Trim(wksB.Cells(j, 1)) Then
If raA Is Nothing Then
Set raA = Rows(i)
Else
Set raA = Union(raA, Rows(i))
End If
End If
Next j
Next i
End With
If Not raA Is Nothing Then
raA.Delete
Set raA = Nothing
End If
End Sub
Sub freieLagerplätze5()
Dim loLetzte1 As Long
Dim loLetzte2 As Long
Dim i As Long, j As Long
Dim raA As Range
Dim wksA As Worksheet
Dim wksB As Worksheet
Set wksA = Sheets("Tabelle1") ' Tabellennamen anpassen; Tabelle in der gelöscht wird
Set wksB = Sheets("Tabelle2") ' Tabellennamen anpassen; Tabelle in der die Werte in Spalte _
A gelistet sind
With wksB
loLetzte2 = IIf(IsEmpty(.Cells(.Rows.Count, 1)), .Cells(.Rows.Count, 1).End(xlUp).Row, . _
Rows.Count)
End With
With wksA
loLetzte1 = IIf(IsEmpty(.Cells(.Rows.Count, 1)), .Cells(.Rows.Count, 1).End(xlUp).Row, . _
Rows.Count)
For i = 2 To loLetzte1
For j = 2 To loLetzte2
If Trim(.Cells(i, 1)) = Trim(wksB.Cells(j, 1)) Then
If raA Is Nothing Then
Set raA = Rows(i)
Else
Set raA = Union(raA, Rows(i))
End If
End If
Next j
Next i
End With
If Not raA Is Nothing Then
raA.Delete
Set raA = Nothing
End If
End Sub
Sub freieLagerplätze2()
Dim lngZeile As Long
Dim lngLetzte As Long
lngZeile = 1
With Worksheets("Tabelle1")
lngLetzte = IIf(IsEmpty(.Cells(.Rows.Count, 1)), .Cells(.Rows.Count, 1).End(xlUp).Row, .Rows. _
Count)
With .Range(.Cells(1, 1), .Cells(lngLetzte, 1))
Do
.Replace What:=Worksheets("Tabelle3").Cells(lngZeile, 1).Value, _
Replacement:=Worksheets("Tabelle3").Cells(lngZeile, 2).Value, LookAt:=xlPart _
, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
lngZeile = lngZeile + 1
Loop While Worksheets("Tabelle3").Cells(lngZeile, 1) ""
End With
End With
End Sub
Hoffe ihr könnt mir helfen:-)
Danke LG Sandra