Benutzer:Gerold Broser/Früchtecocktailshaker
Zur Navigation springen
Zur Suche springen
Marias Version
[Bearbeiten | Quelltext bearbeiten]Option Explicit '-------------------------------------------------- 'Change these according to your actual sheets Const INPUT_SHEET_NAME = "Wertetabelle" Const INPUT_COLUMN_INDEX = 6 Const INPUT_ITEM_SEPARATOR = ";" Const INPUT_ITEMS_MAX = 1000 Const LIST_SHEET_NAME = "Schlagwortliste" Const LIST_COLUMN_INDEX = 3 Const LIST_ROW_INDEX = "6" '-------------------------------------------------- ' ' ' SchlagwortlisteErzeugen() ' =================================== ' 2009-06-20 by Geri Broser ' Looks through all cells of the INPUT_COLUMN_INDEX column in INPUT_SHEET_NAME. ' Distinct items in the cells, separated by ITEM_SEPARATOR, ' are put to the LIST_COLUMN_INDEX column of LIST_SHEET_NAME. ' Spaces around the items are trimmed off. Public Sub SchlagwortlisteErzeugen() Dim inputSheet As Worksheet Set inputSheet = ActiveWorkbook.Worksheets(INPUT_SHEET_NAME) Dim rowIdx As Long Dim cellText As String Dim itemsInCell() As String Dim Item As Variant Dim items() As String 'array to hold all items Dim nextItemIdx As Long nextItemIdx = 0 'clear below headlines Range("B6:C2000").ClearContents 'loop through all cells For rowIdx = LIST_ROW_INDEX To INPUT_ITEMS_MAX cellText = inputSheet.Cells(rowIdx, INPUT_COLUMN_INDEX) If cellText <> vbNullString Then 'get items within cell and add them to items array itemsInCell = Split(cellText, INPUT_ITEM_SEPARATOR) For Each Item In itemsInCell ReDim Preserve items(nextItemIdx) items(nextItemIdx) = Trim(Item) nextItemIdx = nextItemIdx + 1 Next Item End If Next rowIdx Call QuickSort(items) Call putItemsToListSheet(items) End Sub 'Schlagwortliste() ' ' putItemsToListSheet() ' ===================== Private Sub putItemsToListSheet(items) Dim listSheet As Worksheet Set listSheet = ActiveWorkbook.Worksheets(LIST_SHEET_NAME) Dim rowIdx As Long Dim Item As Variant rowIdx = LIST_ROW_INDEX Dim previousItem As String For Each Item In items ' If Item <> vbNullString Then If Item <> previousItem Then listSheet.Cells(rowIdx, LIST_COLUMN_INDEX) = Item rowIdx = rowIdx + 1 End If previousItem = Item Next Item End Sub 'From: http://www.vbarchiv.net/tipps/details.php?id=372 ' QuickSort-Algorithmus ' ' vSort() : zu sortierendes Array ' lngStart, lngEnd: zu sortierender Bereich ' ========================================== Private Sub QuickSort(vSort As Variant, _ Optional ByVal lngStart As Variant, _ Optional ByVal lngEnd As Variant) ' Wird die Bereichsgrenze nicht angegeben, ' so wird das gesamte Array sortiert If IsMissing(lngStart) Then lngStart = LBound(vSort) If IsMissing(lngEnd) Then lngEnd = UBound(vSort) Dim i As Long Dim j As Long Dim h As Variant Dim x As Variant i = lngStart: j = lngEnd x = vSort((lngStart + lngEnd) / 2) ' Array aufteilen Do While (vSort(i) < x): i = i + 1: Wend While (vSort(j) > x): j = j - 1: Wend If (i <= j) Then ' Wertepaare miteinander tauschen h = vSort(i) vSort(i) = vSort(j) vSort(j) = h i = i + 1: j = j - 1 End If Loop Until (i > j) ' Rekursion (Funktion ruft sich selbst auf) If (lngStart < j) Then QuickSort vSort, lngStart, j If (i < lngEnd) Then QuickSort vSort, i, lngEnd End Sub 'QuickSort()
Geris Version
[Bearbeiten | Quelltext bearbeiten]' createDistinctItemsList ' ======================= ' 2009-06-22 by Geri Broser Option Explicit Option Compare Text '-------------------------------------------------- 'Change these according to your actual sheets Const INPUT_SHEET = "Wertetabelle" Const INPUT_NAME_COLUMN = 5 'Note: Const INPUT_ITEMS_COLUMN = 6 'NAME and ITEMS columns must not be the same Const INPUT_ITEMS_SEPARATOR = ";" Const INPUT_BEGIN_ROW = 1 Const INPUT_END_ROW = 1000 Const OUTPUT_SHEET = "Schlagwortliste" Const OUTPUT_ITEM_COLUMN = 3 'Note: Const OUTPUT_NAMES_COLUMN = 4 'ITEM and NAMES columns must not be the same Const OUTPUT_NAMES_SEPARATOR = ", " Const OUTPUT_BEGIN_ROW = 6 '-------------------------------------------------- ' Public Sub SchlagwortlisteErzeugen() Call createDistinctItemsListCompletely End Sub ' ' createDistinctItemsListQuickly() '================================= ' 2009-06-22 by Geri Broser ' Looks through the cells of INPUT_ITEMS_COLUMN in INPUT_SHEET, ' beginning at the first non-empty cell equal or greater than INPUT_BEGIN_ROW, ' ending at the first empty cell or at INPUT_END_ROW. ' Distinct items in these cells, separated by INPUT_ITEMS_SEPARATOR, are put to ' OUTPUT_ITEM_COLUMN in OUTPUT_SHEET, beginning at OUTPUT_BEGIN_ROW. ' Spaces around the items are trimmed off. Private Sub createDistinctItemsListQuickly() Dim items() As String Dim beginRowIdx As Long Dim rowIdx As Long items = getItemsQuickly(beginRowIdx, rowIdx) Call QuickSort(items) Call putDistinctItemsToOutputSheet(items) Call createNamesListsInOutputSheet(beginRowIdx, rowIdx - 1) End Sub ' ' createDistinctItemsListCompletely() ' =================================== ' 2009-06-22 by Geri Broser ' Looks through all cells of INPUT_ITEMS_COLUMN in INPUT_SHEET, ' from INPUT_BEGIN_ROW to INPUT_END_ROW. ' Distinct items in these cells, separated by INPUT_ITEMS_SEPARATOR, are put to ' OUTPUT_ITEM_COLUMN in OUTPUT_SHEET, beginning at OUTPUT_BEGIN_ROW. ' Spaces around the items are trimmed off. Private Sub createDistinctItemsListCompletely() Dim items() As String items = getItemsCompletely() Call QuickSort(items) Call putDistinctItemsToOutputSheet(items) Call createNamesListsInOutputSheet(INPUT_BEGIN_ROW, INPUT_END_ROW) End Sub ' ' getItemsQuickly() ' ================= ' 2009-06-22 by Geri Broser Private Function getItemsQuickly(ByRef beginRowIdx As Long, ByRef rowIdx As Long) As String() Dim inputSheet As Worksheet Set inputSheet = ActiveWorkbook.Worksheets(INPUT_SHEET) Dim itemsList As String Dim itemsInList() As String 'array to hold items in one list (one cell) Dim item As Variant Dim items() As String 'array to hold all items ReDim Preserve items(0) 'get first non-empty cell rowIdx = INPUT_BEGIN_ROW - 1 Do rowIdx = rowIdx + 1 itemsList = inputSheet.Cells(rowIdx, INPUT_ITEMS_COLUMN) Loop Until itemsList <> vbNullString beginRowIdx = rowIdx itemsInList = Split(itemsList, INPUT_ITEMS_SEPARATOR) Dim itemIdx As Long itemIdx = 0 ReDim Preserve items(UBound(itemsInList)) 'loop through cells until first empty cell Do While itemsList <> vbNullString And rowIdx <= INPUT_END_ROW 'get items within cell and add them to items For Each item In itemsInList items(itemIdx) = Trim(item) itemIdx = itemIdx + 1 Next item 'get next cell rowIdx = rowIdx + 1 itemsList = inputSheet.Cells(rowIdx, INPUT_ITEMS_COLUMN) itemsInList = Split(itemsList, ",") itemIdx = UBound(items) + 1 ReDim Preserve items(itemIdx + UBound(itemsInList)) Loop getItemsQuickly = items End Function 'getItemsQuickly() ' ' getItemsCompletely() ' ==================== ' 2009-06-22 by Geri Broser Private Function getItemsCompletely() As String() Dim inputSheet As Worksheet Set inputSheet = ActiveWorkbook.Worksheets(INPUT_SHEET) Dim rowIdx As Long Dim itemsList As String Dim itemsInList() As String 'array to hold items in one list (one cell) Dim item As Variant Dim items() As String 'array to hold all items Dim itemIdx As Long itemIdx = 0 'loop through all cells For rowIdx = INPUT_BEGIN_ROW To INPUT_END_ROW itemsList = inputSheet.Cells(rowIdx, INPUT_ITEMS_COLUMN) If itemsList <> vbNullString Then 'get items within cell and add them to items array itemsInList = Split(itemsList, INPUT_ITEMS_SEPARATOR) For Each item In itemsInList ReDim Preserve items(itemIdx) items(itemIdx) = Trim(item) itemIdx = itemIdx + 1 Next item End If Next rowIdx getItemsCompletely = items End Function 'getItemsCompletely() ' ' putDistinctItemsToOutputSheet() ' =============================== ' 2009-06-20 by Geri Broser Private Sub putDistinctItemsToOutputSheet(items) Dim outputSheet As Worksheet Set outputSheet = ActiveWorkbook.Worksheets(OUTPUT_SHEET) 'clear output range outputSheet.Activate outputSheet.Range(outputSheet.Cells(OUTPUT_BEGIN_ROW, OUTPUT_ITEM_COLUMN), _ outputSheet.Cells(outputSheet.Columns(OUTPUT_ITEM_COLUMN).Rows.Count, OUTPUT_ITEM_COLUMN)).Select Selection.ClearContents Dim rowIdx As Long 'clearing by iterating is much slower 'For rowIdx = 1 To outputSheet.Columns(LIST_COLUMN_INDEX).Rows.Count ' outputSheet.Cells(rowIdx, INPUT_COLUMN_INDEX) = vbNullString 'Next rowIdx Dim item As Variant rowIdx = OUTPUT_BEGIN_ROW Dim previousItem As String For Each item In items If item <> previousItem Then outputSheet.Cells(rowIdx, OUTPUT_ITEM_COLUMN) = item rowIdx = rowIdx + 1 End If previousItem = item Next item End Sub 'putDistinctItemsToOutputSheet() ' ' createNamesListsInOutputSheet() ' =============================== ' 2009-06-22 by Geri Broser Private Sub createNamesListsInOutputSheet(inputBeginRow As Long, inputEndRow As Long) Dim outputSheet As Worksheet Set outputSheet = ActiveWorkbook.Worksheets(OUTPUT_SHEET) 'clear output range outputSheet.Activate outputSheet.Range(outputSheet.Cells(OUTPUT_BEGIN_ROW, OUTPUT_NAMES_COLUMN), _ outputSheet.Cells(outputSheet.Columns(OUTPUT_NAMES_COLUMN).Rows.Count, OUTPUT_NAMES_COLUMN)).Select Selection.ClearContents Dim inputSheet As Worksheet Set inputSheet = ActiveWorkbook.Worksheets(INPUT_SHEET) Dim outputRowIdx As Long Dim item As String Dim inputRowIdx As Long Dim nameList As String Dim names() As String 'array to hold all names Dim nameIdx As Long Dim name As Variant outputRowIdx = OUTPUT_BEGIN_ROW item = outputSheet.Cells(outputRowIdx, OUTPUT_ITEM_COLUMN) 'loop through output items Do While item <> vbNullString nameList = vbNullString nameIdx = 0 'find input names for output item For inputRowIdx = inputBeginRow To inputEndRow If InStr(inputSheet.Cells(inputRowIdx, INPUT_ITEMS_COLUMN), item) > 0 Then ReDim Preserve names(nameIdx) names(nameIdx) = inputSheet.Cells(inputRowIdx, INPUT_NAME_COLUMN) nameIdx = nameIdx + 1 End If Next inputRowIdx Call QuickSort(names) 'create separated output list from list array For Each name In names nameList = nameList & name & OUTPUT_NAMES_SEPARATOR Next name 'remove trailing OUTPUT_NAMELIST_SEPARATOR outputSheet.Cells(outputRowIdx, OUTPUT_NAMES_COLUMN) = _ Left(nameList, Len(nameList) - Len(OUTPUT_NAMES_SEPARATOR)) outputRowIdx = outputRowIdx + 1 item = outputSheet.Cells(outputRowIdx, OUTPUT_ITEM_COLUMN) Loop End Sub 'createNamesListsInOutputSheet() ' 'From: http://www.vbarchiv.net/tipps/tipp_372-quicksort-in-vb.html ' QuickSort-Algorithmus ' ' vSort() : zu sortierendes Array ' lngStart, lngEnd: zu sortierender Bereich ' ========================================== Private Sub QuickSort(vSort As Variant, _ Optional ByVal lngStart As Variant, _ Optional ByVal lngEnd As Variant) ' Wird die Bereichsgrenze nicht angegeben, ' so wird das gesamte Array sortiert If IsMissing(lngStart) Then lngStart = LBound(vSort) If IsMissing(lngEnd) Then lngEnd = UBound(vSort) Dim i As Long Dim j As Long Dim h As Variant Dim x As Variant i = lngStart: j = lngEnd x = vSort((lngStart + lngEnd) / 2) ' Array aufteilen Do While (vSort(i) < x): i = i + 1: Wend While (vSort(j) > x): j = j - 1: Wend If (i <= j) Then ' Wertepaare miteinander tauschen h = vSort(i) vSort(i) = vSort(j) vSort(j) = h i = i + 1: j = j - 1 End If Loop Until (i > j) ' Rekursion (Funktion ruft sich selbst auf) If (lngStart < j) Then QuickSort vSort, lngStart, j If (i < lngEnd) Then QuickSort vSort, i, lngEnd End Sub 'QuickSort()