AW: Zeilen untereinander kopieren
11.09.2011 12:59:21
Tino
Hallo,
den Verweis hatte ich zu testzwecken gesetzt und vergessen diesen wieder zu entfernen.
Hier die Anpassung u. den Verweis musst Du auch nicht mehr setzen.
Sub Start()
Dim rngFind As Range, rngTmp As Range, rngSuchBereich As Range
Dim strEerste As String
Dim varSuchZahl
Dim iCalc As Integer
Dim varArray
Dim oWS As Worksheet
varSuchZahl = InputBox("Suche nach", "Geben Sie die zu suchende Zahl ein")
If Not IsNumeric(varSuchZahl) Then Exit Sub
'Tabelle anpassen
Set rngSuchBereich = Tabelle1.Range("B:H")
Set rngFind = rngSuchBereich.Find(What:=varSuchZahl, LookIn:=xlValues, LookAt:= _
xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False _
, SearchFormat:=False)
If Not rngFind Is Nothing Then
With Application
iCalc = .Calculation
.ScreenUpdating = False
.EnableEvents = False
.Calculation = xlCalculationManual
strEerste = rngFind.Address
If rngFind.Row < rngSuchBereich.Rows.Count Then _
Set rngTmp = rngSuchBereich.Rows(rngFind.Row + 1)
Set rngFind = rngSuchBereich.FindNext(rngFind)
Do While rngFind.Address <> strEerste
If rngFind.Row < rngSuchBereich.Rows.Count Then _
Set rngTmp = Union(rngSuchBereich.Rows(rngFind.Row + 1), rngTmp)
Set rngFind = rngSuchBereich.FindNext(rngFind)
Loop
With ThisWorkbook
'A bis E **********************************
Zusammenfassen varArray, rngTmp, 1, 5
If IsArray(varArray) Then
If oWS Is Nothing Then Set oWS = .Sheets.Add(After:=.Sheets(.Sheets.Count))
With oWS
.Cells(2, 1).Resize(Ubound(varArray), 2) = varArray
.Cells(1, 1) = "A-E"
.Cells(1, 2) = "Anzahl"
End With
End If
varArray = Empty
'F bis G **********************************
Zusammenfassen varArray, rngTmp, 6, 7
If IsArray(varArray) Then
If oWS Is Nothing Then Set oWS = .Sheets.Add(After:=.Sheets(.Sheets.Count))
With oWS
.Cells(2, 3).Resize(Ubound(varArray), 2) = varArray
.Cells(1, 3) = "F-G"
.Cells(1, 4) = "Anzahl"
End With
End If
varArray = Empty
If Not oWS Is Nothing Then
With oWS
.Rows(1).Font.Bold = True
.UsedRange.EntireColumn.AutoFit
End With
End If
End With
.Calculation = iCalc
.ScreenUpdating = True
.EnableEvents = True
End With
End If
End Sub
Sub Zusammenfassen(varArray, rngRange As Range, lngVonCol&, lngBisCol&)
Dim oDic As Object, meAr(), n&, nn&
Dim rng As Range
Set oDic = CreateObject("Scripting.Dictionary")
For Each rng In rngRange.Areas
meAr = rng.Value2
For n = Lbound(meAr) To Ubound(meAr)
For nn = lngVonCol To lngBisCol
If meAr(n, nn) <> "" Then _
oDic(meAr(n, nn)) = oDic(meAr(n, nn)) + 1
Next nn
Next n
Next
Erase meAr
If oDic.Count = 0 Then Exit Sub
meAr = TransposeArray(oDic.Keys, oDic.items)
Redim Preserve meAr(Lbound(meAr) To Ubound(meAr), 1 To 2)
prcQuickSort Lbound(meAr), Ubound(meAr), 1, True, meAr
varArray = meAr
End Sub
Function TransposeArray(varArrayKeys, varArrayItems)
Dim n&, NewArray()
Redim Preserve NewArray(Lbound(varArrayKeys) + 1 To Ubound(varArrayKeys) + 1, 1 To 2)
For n = Lbound(varArrayKeys) To Ubound(varArrayKeys)
NewArray(n + 1, 1) = varArrayKeys(n)
NewArray(n + 1, 2) = varArrayItems(n)
Next n
TransposeArray = NewArray
End Function
' Code Max Kaffl
Private Sub prcQuickSort(lngLbound As Long, lngUbound As Long, _
intSortColumn As Integer, bntSortKey As Boolean, vntArray() As Variant)
Dim intIndex As Integer
Dim lngIndex1 As Long, lngIndex2 As Long
Dim vntTemp As Variant, vntBuffer As Variant
lngIndex1 = lngLbound
lngIndex2 = lngUbound
vntBuffer = vntArray((lngLbound + lngUbound) \ 2, intSortColumn)
Do
If bntSortKey Then
Do While vntArray(lngIndex1, intSortColumn) < vntBuffer
lngIndex1 = lngIndex1 + 1
Loop
Do While vntBuffer < vntArray(lngIndex2, intSortColumn)
lngIndex2 = lngIndex2 - 1
Loop
Else
Do While vntArray(lngIndex1, intSortColumn) > vntBuffer
lngIndex1 = lngIndex1 + 1
Loop
Do While vntBuffer > vntArray(lngIndex2, intSortColumn)
lngIndex2 = lngIndex2 - 1
Loop
End If
If lngIndex1 < lngIndex2 Then
If vntArray(lngIndex1, intSortColumn) <> _
vntArray(lngIndex2, intSortColumn) Then
For intIndex = Lbound(vntArray, 2) To Ubound(vntArray, 2)
vntTemp = vntArray(lngIndex1, intIndex)
vntArray(lngIndex1, intIndex) = _
vntArray(lngIndex2, intIndex)
vntArray(lngIndex2, intIndex) = vntTemp
Next
End If
lngIndex1 = lngIndex1 + 1
lngIndex2 = lngIndex2 - 1
ElseIf lngIndex1 = lngIndex2 Then
lngIndex1 = lngIndex1 + 1
lngIndex2 = lngIndex2 - 1
End If
Loop Until lngIndex1 > lngIndex2
If lngLbound < lngIndex2 Then Call prcQuickSort(lngLbound, _
lngIndex2, intSortColumn, bntSortKey, vntArray())
If lngIndex1 < lngUbound Then Call prcQuickSort(lngIndex1, _
lngUbound, intSortColumn, bntSortKey, vntArray())
End Sub
Gruß Tino