Comments? Advanced "Copy Columns" function code 2

[VBAjedi]

Follow-up to thread707-698561 . Thought I'd post this code (sorry about the length) for comment or for others to use. It's a function that, when passed a string like "A, D:F, B(12), K:M(8.5)" copies the values/formats in those columns to a new workbook and sets the column widths to the values in parentheses (if specified). Useful for creating simplified snapshot "views" of a complex spreadsheet for executives or salespeople (not that I have any experience with needing that! [ROFL]) Anyone care to suggest tweaks to this function?

Function CopyCols(ColList, SourceSheet As Worksheet, TitleText)
' Copies columns to a new workbook, returns new workbook reference.
' ColList should be in the form "A, C(14),F, E, J:L (8),P"
'     (spaces ignored before/after commas, multiple-column references
'     like 'J:L' allowed, optional column widths in parentheses after letter)
' Columns MUST NOT contain merged cells (or column will be skipped)!
'     This limitation could be bypassed by modifying code to copy
'     a range like "A1:A1000" instead of the whole column

Dim ColArray(2, 200), FirstEmptyCol As Integer
Dim wsThis As Worksheet, wbNew As Workbook, wsNew As Worksheet
Dim x, y, z, a ' utility variables

If Len(ColList) = 0 Then Exit Function

' Parse ColList, store in two-dimensional array (Dimension 1=ColLetterRef, 2=ColWidth)
x = 1
y = 1
z = 0
Do
   a = Mid(ColList, x, 1)
   Select Case a
   Case ",", "(", "" ' separator or end of list found
      z = z + 1 ' column counter
      ColArray(1, z) = Trim(Mid(ColList, y, (x - y)))
      If InStr(1, ColArray(1, z), &quot;:&quot;) < 1 Then ' Is a single-column reference
         ColArray(1, z) = ColArray(1, z) & &quot;:&quot; & ColArray(1, z)
      End If
      x = x + 1 ' advance to start of next section (either width or next column)
      y = x ' reset starting marker
      If a = &quot;(&quot; Then ' a width was specified for this column
         Do Until Mid(ColList, x, 1) = &quot;)&quot; Or Mid(ColList, x, 1) = &quot;&quot;
            x = x + 1 ' advance to end of width bracket
         Loop
         ColArray(2, z) = Trim(Mid(ColList, y, (x - y))) ' store width in array
         ' In case there are spaces between &quot;)&quot; and &quot;,&quot; :
         Do Until Mid(ColList, x, 1) = &quot;,&quot; Or Mid(ColList, x, 1) = &quot;&quot;
            x = x + 1 ' advance to next column
         Loop
         x = x + 1 ' advance to start of next column section
         y = x ' reset starting marker
      End If
      ' Verify parser's results:
      Debug.Print ColArray(1, z) & &quot;, &quot; & ColArray(2, z)
   Case Else ' Keep looking for a separator or end of list
      x = x + 1
   End Select
Loop While x <= Len(ColList)
    
' Add workbook, copy column values/formats, and adjust column widths if specified
Set wsThis = SourceSheet
Set wbNew = Workbooks.Add
Set wsNew = wbNew.Worksheets(1)
x = 0
y = 0
FirstEmptyCol = 1
For i = 1 To z ' loop through ColArray
   Do While Not ColumnIsEmpty(wsNew, FirstEmptyCol)
      FirstEmptyCol = FirstEmptyCol + 1
   Loop
   ' Copy column(s)
   On Error Resume Next ' Copy causes error if column contains merged cells
   wsThis.Columns(ColArray(1, i)).Copy
   wsNew.Cells(1, FirstEmptyCol).PasteSpecial (xlPasteValues)
   wsNew.Cells(1, FirstEmptyCol).PasteSpecial (xlPasteFormats)
   On Error GoTo 0
   ' Now set column width(s)
   If Len(ColArray(2, i)) > 0 Then ' a width was specified for this column
      x = Selection.Columns.Count
      For y = FirstEmptyCol To (FirstEmptyCol + x - 1) ' loop through pasted columns
         wsNew.Columns(y).ColumnWidth = ColArray(2, i)
      Next y
   End If
   FirstEmptyCol = FirstEmptyCol + 1
Next
If Len(TitleText) > 0 Then
   wsNew.Rows(1).Insert
   With wsNew.Range(&quot;A1&quot;) 'Cells(1, 1)
      .Value = TitleText
      .Font.Size = 14
      .Font.Bold = True
      .Font.Underline = True
   End With
End If


Set CopyCols = wbNew

End Function

Function ColumnIsEmpty(Ws As Worksheet, ColNum As Integer) As Boolean
Dim r As Range
  Set r = Ws.Cells(1, ColNum)
  If IsEmpty(r) Then ' First cell is empty
    Set r = r.End(xlDown) ' Returns row 65536 if no earlier cell has contents
    If IsEmpty(r) Then ColumnIsEmpty = True ' Whole column is empty
  End If
  Set r = Nothing
End Function

Thanks!

VBAjedi

 

[RobBroekhuis]

Your code is fine, so tweaking borders on silly. But here's a silly suggestion:

replace:
x = Selection.Columns.Count
For y = FirstEmptyCol To (FirstEmptyCol + x - 1)
wsNew.Columns.ColumnWidth = ColArray(2, i)
Next y

with
wsNew.columns(firstemptycol-selection.column+1).range(selection.range(0,0)).columnwidth=colarray(2,i)

It's a monster, but it saves 3 lines


Rob

 

[TonyJollans]

Hi VBAjedi,

I'm usually in the market for silly suggestions

I don't know about performance (although I think it should be OK) but you could recode your ColumnIsEmpty routine as a single line as well (and then take it in-line) ..

ColumnIsEmpty = Ws.Columns(ColNum).Find("*&quot Is Nothing

Enjoy,
Tony

 

[VBAjedi]

Tony - nice! Any time you can eliminate a function it can hardly be called "silly"!

Rob - I was about to tell you that I couldn't get your code to work because the selection can be multiple columns (truth be known I couldn't quite grasp what you were doing with the Selection to debug it, though, so it could have been a dumb error on my part). Then I had one of those "Duh!" moments and realized that I don't need to know column numbers because the columns I am interested in were just pasted and are still highlighted. So I tried:

Selection.Columns.ColumnWidth = ColArray(2, i)

which seems to work perfectly.

Thanks for your input, gentlemen! It's nice to have friends that understand the satisfaction that can be derived from finding a way to eliminate a function or three lines of code. . .


VBAjedi

 

[RobBroekhuis]

Wow! I didn't know you could do that. I'll have to go play around with it and see if I have code of my own that can be improved similarly.


Rob