added "Multivalue cells" macro

Author: sergey-frolov-pm

roadmap/excel-helpers.xmind

@@ -0,0 +1,91 @@
+VERSION 5.00
+Begin {C62A69F0-16DC-11CE-9E98-00AA00574A4F} FMultiValues 
+   Caption         =   "Select Values for Cell:"
+   ClientHeight    =   3555
+   ClientLeft      =   45
+   ClientTop       =   375
+   ClientWidth     =   7200
+   OleObjectBlob   =   "FMultiValues.frx":0000
+   StartUpPosition =   1  'CenterOwner
+End
+Attribute VB_Name = "FMultiValues"
+Attribute VB_GlobalNameSpace = False
+Attribute VB_Creatable = False
+Attribute VB_PredeclaredId = True
+Attribute VB_Exposed = False
+Private Sub btnAll_Click()
+Dim i As Integer
+
+For i = 0 To lstVal.ListCount - 1
+    lstVal.Selected(i) = True
+Next
+End Sub
+
+Private Sub btnCancel_Click()
+Me.Hide
+End Sub
+
+Private Sub btnOK_Click()
+
+Dim selectedValues As String
+Dim i As Integer
+Dim s As Variant
+
+selectedValues = vbNullString
+
+For i = 0 To lstVal.ListCount - 1
+    If lstVal.Selected(i) = True Then selectedValues = selectedValues & lstVal.List(i) & txtSep.text
+Next
+
+For Each s In Selection.cells
+    
+    If selectedValues = vbNullString Then
+        s.Value = vbNullString
+    Else
+        s.Value = Mid(selectedValues, 1, Len(selectedValues) - Len(txtSep.text))
+    End If
+    
+Next
+
+Me.Hide
+
+End Sub
+
+Private Sub btnReset_Click()
+Dim i As Integer
+        
+For i = 0 To lstVal.ListCount - 1
+    lstVal.Selected(i) = False
+Next
+
+End Sub
+
+Private Sub btnUpdateFromCells_Click()
+Dim cell As Variant
+
+On Error Resume Next
+
+lstVal.Clear
+
+For Each cell In Selection.cells
+    lstVal.AddItem cell.Value
+Next
+
+Me.Hide
+End Sub
+
+Private Sub btnUpdateOptions_Click()
+Dim varArray As Variant
+Dim cell As Variant
+
+On Error Resume Next
+
+varArray = Split(PasteFromClipboard(), vbCrLf)
+
+lstVal.Clear
+
+For Each cell In varArray
+    If cell <> vbNullString Then lstVal.AddItem cell
+Next
+
+End Sub

tools/multivalue_cells/sfMultiValueCells.xlsm

@@ -0,0 +1,124 @@
+Attribute VB_Name = "MClipboard"
+Declare Function GlobalUnlock Lib "kernel32" (ByVal hMem As Long) As Long
+Declare Function GlobalLock Lib "kernel32" (ByVal hMem As Long) As Long
+Declare Function GlobalAlloc Lib "kernel32" (ByVal wFlags As Long, ByVal dwBytes As Long) As Long
+Declare Function CloseClipboard Lib "User32" () As Long
+Declare Function OpenClipboard Lib "User32" (ByVal hwnd As Long) As Long
+Declare Function EmptyClipboard Lib "User32" () As Long
+Declare Function lstrcpy Lib "kernel32" (ByVal lpString1 As Any, ByVal lpString2 As Any) As Long
+Declare Function SetClipboardData Lib "User32" (ByVal wFormat As Long, ByVal hMem As Long) As Long
+Declare Function GetClipboardData Lib "User32" (ByVal wFormat As Long) As Long
+Declare Function GlobalSize Lib "kernel32" (ByVal hMem As Long) As Long
+
+Public Const GHND = &H42
+Public Const CF_TEXT = 1
+Public Const MAXSIZE = 4096
+
+Private Const RAISE_ERROR = False
+
+Public Function CopyToClipboard(myString As String) As Boolean
+   Dim hGlobalMemory As Long, lpGlobalMemory As Long
+   Dim hClipMemory As Long, hTmp As Long
+
+   ' Allocate moveable global memory.
+   hGlobalMemory = GlobalAlloc(GHND, Len(myString) + 1)
+
+   ' Lock the block to get a far pointer to this memory.
+   lpGlobalMemory = GlobalLock(hGlobalMemory)
+
+   ' Copy the string to this global memory.
+   lpGlobalMemory = lstrcpy(lpGlobalMemory, myString)
+
+   ' Unlock the memory.
+   If GlobalUnlock(hGlobalMemory) <> 0 Then
+      If RAISE_ERROR Then
+        Err.Raise 520, "CopyToClipboard", "Could not unlock memory location."
+      Else
+        CopyToClipboard = False
+        GoTo mrk
+      End If
+   End If
+
+   ' Open the Clipboard to copy data to.
+   If OpenClipboard(0&) = 0 Then
+      If RAISE_ERROR Then
+        Err.Raise 521, "CopyToClipboard", "Could not open the Clipboard."
+      Else
+        CopyToClipboard = False
+        Exit Function
+      End If
+   End If
+
+   ' Clear the Clipboard.
+   hTmp = EmptyClipboard()
+
+   ' Copy the data to the Clipboard.
+   hClipMemory = SetClipboardData(CF_TEXT, hGlobalMemory)
+
+mrk:
+
+   If CloseClipboard() = 0 Then
+        If RAISE_ERROR Then
+           Err.Raise 521, "CopyToClipboard", "Could not close the Clipboard."
+        Else
+            CopyToClipboard = False
+            Exit Function
+        End If
+   Else
+        CopyToClipboard = True
+   End If
+
+   End Function
+
+Public Function PasteFromClipboard() As String
+   Dim hClipMemory As Long
+   Dim lpClipMemory As Long
+   Dim myString As String
+   Dim RetVal As Long
+
+   If OpenClipboard(0&) = 0 Then
+      If RAISE_ERROR Then
+        Err.Raise 521, "PasteFromClipboard", "Could not open the Clipboard."
+      Else
+        PasteFromClipboard = vbNullString
+        Exit Function
+      End If
+   End If
+
+   ' Obtain the handle to the global memory block that is referencing the text.
+   hClipMemory = GetClipboardData(CF_TEXT)
+   
+   If IsNull(hClipMemory) Then
+       If RAISE_ERROR Then
+         Err.Raise 520, "PasteFromClipboard", "Could not allocate memory."
+       Else
+         PasteFromClipboard = False
+         GoTo mrk
+       End If
+   End If
+
+   ' Lock Clipboard memory so we can reference the actual data string.
+   lpClipMemory = GlobalLock(hClipMemory)
+
+   If Not IsNull(lpClipMemory) Then
+      myString = Space$(MAXSIZE)
+      RetVal = lstrcpy(myString, lpClipMemory)
+      RetVal = GlobalUnlock(hClipMemory)
+
+      ' Peel off the null terminating character.
+      myString = Mid(myString, 1, InStr(1, myString, Chr$(0), 0) - 1)
+   Else
+       If RAISE_ERROR Then
+         Err.Raise 520, "PasteFromClipboard", "Could not lock memory to copy string from."
+       Else
+         PasteFromClipboard = False
+         GoTo mrk
+       End If
+   End If
+
+mrk:
+
+   RetVal = CloseClipboard()
+   PasteFromClipboard = myString
+
+End Function

tools/multivalue_cells/src/FMultiValues.frm

@@ -0,0 +1,47 @@
+Attribute VB_Name = "MMultivalues"
+Private frm As FMultiValues
+Private isLoaded As Boolean
+
+Public Sub ShowMultiValuesBox()
+Dim sep As String
+Dim old As Variant
+Dim o As Variant
+
+If isLoaded Then
+    If frm.lstVal.ListCount > 0 Then
+        For i = 0 To frm.lstVal.ListCount - 1
+           frm.lstVal.Selected(i) = False
+        Next
+        
+        sep = frm.txtSep.text
+        old = Split(ActiveCell.Value, sep)
+        
+        For Each o In old
+            For i = 0 To frm.lstVal.ListCount - 1
+                If frm.lstVal.List(i) = o Then
+                    frm.lstVal.Selected(i) = True
+                    Exit For
+                End If
+            Next
+        Next
+    End If
+Else
+    Set frm = New FMultiValues
+    isLoaded = True
+End If
+
+If Selection.cells.Count > 1 Then
+   o = Replace(Selection.Address, "$", "")
+   frm.Caption = "Select values for cells {" & o & "}"
+Else
+   o = Replace(ActiveCell.Address, "$", "")
+   
+   sep = ActiveCell.Value
+   If sep = vbNullString Then sep = "empty"
+   
+   frm.Caption = "Select values for cell {" & o & "} current value: " & sep
+End If
+
+frm.lstVal.SetFocus
+frm.Show 1
+End Sub