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()
' 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()
