Copy non-contiguous columns onto Sheet2 and form a vertical stacking table

Question

Everything works as expected.

This will look for the value of pptText in Sheet1 and then copy it onto Sheet2 to form a table. I will add something that copies then pastes the tables on Sheet2 onto another sheet after each iteration of the arrayLoop, but this works for now.

This is what Sheet1 looks like:

enter image description here

And this is what Sheet2 looks like after running this code:

Sheet2

Any help scrubbing/shortening/or making this code faster, smoother and more efficient is appreciated!

Option Explicit
Sub chkPercent()
 Dim wb As Workbook
 Dim ShRef As Worksheet
 Dim ShWork As Worksheet
 Dim rng As Range
 Set wb = ActiveWorkbook
 Set ShRef = wb.Worksheets(1)
 Set rng = ShRef.Range("A1")
 Dim iq_Array As Variant
 Dim colNumb As Long
 Dim rowNumb As Long
 Application.ScreenUpdating = False
 colNumb = ShRef.Cells(1, ShRef.Columns.Count).End(xlToLeft).Column
 rowNumb = ShRef.Cells(ShRef.Rows.Count, 1).End(xlUp).Row
 Dim iQRef() As String
 Dim iCol As Long
 Dim pptText As String
 ReDim iQRef(colNumb)
 ' capture IQ refs locally
 For iCol = 2 To colNumb
 iQRef(iCol) = ShRef.Cells(1, iCol).Value
 Next iCol
 Worksheets.Add After:=ShRef
 Set ShWork = wb.Worksheets(2)
 pptText = "iq_9"
 'Identify if within text there is "iq_"
 'If InStr(1, pptText, "iq_") <= 0 Then GoTo nextShpe
 'set iq_Array as an array of the split iq's
 iq_Array = Split(pptText, ",")
 Dim hasIQs As Boolean
 Dim checkStr As String
 Dim pCol As Long
 Dim checkOne
 Dim arrayLoop As Long
 checkOne = iq_Array(0)
 hasIQs = Left(checkOne, 3) = "iq_"
 If hasIQs Then
 ' paste inital column into temporary worksheet
 ShRef.Columns(1).Copy Destination:=ShWork.Columns(1)
 End If
 ' loop for each iq_ in the array
 For arrayLoop = LBound(iq_Array) To UBound(iq_Array)
 ' Take copy of potential ref and adjust to standard if required
 checkStr = iq_Array(arrayLoop)
 If hasIQs And Left(checkStr, 3) <> "iq_" Then checkStr = "iq_" & checkStr
 Dim iQRefArray As Variant
 Dim iQRefString As String
 Dim checkRefStr As String
 Dim nCol As Long
 Dim doUntilCheck As String
 Dim rowCount As Long
 Dim copy1
 Dim paste1
 doUntilCheck = 99
 ' Look for existence of corresponding column in local copy array
 pCol = 0
 For iCol = 2 To colNumb
 iQRefString = Left(iQRef(iCol), Len(iQRef(iCol)) - 1)
 iQRefArray = Replace(iQRefString, "__", "_")
 iQRefArray = Split(iQRefArray, "_")
 checkRefStr = "iq_" & iQRefArray(1)
 If checkStr = checkRefStr Then
 pCol = iCol
 Exit For
 End If
 Next iCol
 If pCol > 0 Then
 ' Paste the corresponding column into the forming table
 ShRef.Columns(pCol).Copy Destination:=ShWork.Columns(2)
 If iQRefArray(2) = "00" Then GoTo nxtArrayLoop
 nCol = 0
 rowCount = 1
 Do Until doUntilCheck = "00"
 Do Until doUntilCheck = "01"
 nCol = nCol + 1
 rowCount = rowCount + rowNumb
 iQRefString = Left(iQRef(iCol + nCol), Len(iQRef(iCol + nCol)) - 1)
 iQRefArray = Replace(iQRefString, "__", "_")
 iQRefArray = Split(iQRefArray, "_")
 doUntilCheck = iQRefArray(2)
 If doUntilCheck = "00" Then GoTo nxtArrayLoop
 If doUntilCheck = "01" Then GoTo nxtArrayLoop
 ShRef.Range(ShRef.Cells(ShRef.Rows.Count, 1).End(xlUp), ShRef.Cells(1, 1)).Copy Destination:=ShWork.Cells(rowCount, 1)
 ShRef.Range(ShRef.Cells(ShRef.Rows.Count, pCol + nCol).End(xlUp), ShRef.Cells(1, pCol + nCol)).Copy Destination:=ShWork.Cells(rowCount, 2)
 Loop
 Loop
 End If
nxtArrayLoop:
 Next arrayLoop
 Application.ScreenUpdating = True
End Sub

Answer 1

• Option Explicit - excellent! (this should be required in all modules, by default)
• Sub chkPercent() - should be declared explicitly Public (or Private), accordingly
• I found it hard to notice where wb was set
• Set wb = ActiveWorkbook should be Set wb =ThisWorkbook (current file where the code is)
• Naming convention is a bit cryptic
  • I'm not sure what iCol signifies, or what iQRef is used for
  • colNumb, rowNumb should indicate that they refer to the last Row/Col
• Very nice use of arrays to speed things up with iQRef(), but
  • You're redimming it to all columns when you know you'll not be using the first 2
  • It doesn't cause any harm, but you have the first 2 elements unused
  • You're excluding the 2nd col because of your test data but only the 1st column should be excluded by default
• Most of the code is indented 2 levels, instead of just one - is this significant in any way?

• Makes the assumption that the main sheet (ShRef) is the first one in Worksheets collection

   Worksheets.Add After:=ShRef
   Set ShWork = wb.Worksheets(2)
  

• pptText can safely be a CONST, using less resources and performing better

   Dim pptText As String
   pptText = "iq_9"
  

• I'm not sure why you generate an array of a single element iq_Array = Split(pptText, ",")

  • I'm guessing you want to add more items later
    • If that's the case the implementation of the system is incomplete
  • It looks like you are preparing to have identifiers with different numbers
  • hasIQs = Left(checkOne, 3) = "iq_" but this is just complicating things
  • When all your identifiers could be declared like this
    • Const TARGET_COL = "iq_3_,iq_7_,iq_9_,iq_11_", etc (don't need separate parsing)
• Comments can be very useful but don't describe WHAT the code is doing - it should be clear by reading the code * You'll end up maintaining 2 items: code AND comments
  • If the code or its purpose is not obvious, do describe WHY the code is doing something or why it does something unexpected
  • Comments should be replaced by intuitive naming convention for variable and procedure names that could replace comments by describing their purpose and usage
• Don't declare variables in loops; it adds unnecessary overhead for GC (garbage collector) for every iteration
• Very convoluted logic
  • You perform the same check twice: If hasIQs And Left(checkStr, 3) <> "iq_" Then
  • checkStr = "iq_" & checkStr results in "iq_iq_9"
    • The bug above is hidden because the conditions will never be true
    • Similar to If "a" = "a" and "a" <> "a" Then
• What's the significance of doUntilCheck = 99? Temporary statement to allow you to enter the Do Until doUntilCheck = "00" loop? (I had to hunt down the reason). 99 is a magic (random) number.
• There are way too many nesting levels of the most intensive work: loops
  • You have a Do Until inside another Do Until, inside a For
    • The outermost loop contains another For loop (!)
  • The loops need the utmost attention and efficiency
  • Remove all unnecessary logic from each and every loop
  • Don't add nesting layers unless absolutely necessary
    • This is where performance decreases exponentially (arrays or not)
• The inner For: are you expecting identifiers to contain __?:
  • iQRefArray = Replace(iQRefString, "__", "_")
  • How are the __ relevant when you are only using the start of the identifier (iq_3_,iq_7_,iq_9_,iq_11_)?
• On the other hand, you do a lot of validation which is very good (I tend to do the same) but too much of it becomes very expensive so we need to look for the best balance
• The GoTo is a red flag - your flow is broken, now you start to jump, and the logic and motivation becomes extremely hard to follow (at least I wouldn't spend time trying to understand it)

• Repeating logic for processing column headers:

   iQRefString = Left(iQRef(iCol + nCol), Len(iQRef(iCol + nCol)) - 1)
   iQRefArray = Replace(iQRefString, "__", "_")
   iQRefArray = Split(iQRefArray, "_")
  

• You're overcautious and the redundancy doesn't produce the validation you expect

  • You are testing based on the identifier initial length Left() + Len()
  • Yet you want to remove any extra underscores AFTER the validation
    • If there are extra underscores the validation will fail on the first test

• 2 more GoTo statements (somehow connected to the first)

   doUntilCheck = iQRefArray(2)
   If doUntilCheck = "00" Then GoTo nxtArrayLoop
   If doUntilCheck = "01" Then GoTo nxtArrayLoop
  

  • It looks like you want to do different processing for (or exclude) identifiers containing 00 and 01? (is this an extra requirement?)
  • There are multiple ways to accomplish the task of GoTo, but require a bit more work - the price for being clear and making the code easy to maintain in the long run

---

This is how I would attempt to accomplish the task:

Main Sub:

Option Explicit
Public Sub TransposeCols()
 Const START_COL = 2
 Const TARGET_COL = "iq_9_,iq_11_"
 optimizeXL True
 Dim ws1 As Worksheet, ws2 As Worksheet, lr1 As Long, lc1 As Long
 Set ws1 = Sheet1
 With ws1.UsedRange
 lr1 = .Rows.Count
 lc1 = .Columns.Count
 .Range(.Cells(1, 2), .Cells(1, lc1)).EntireColumn.Hidden = True
 End With
 Set ws2 = GetWs2("Output", ws1)
 If Not ws2 Is Nothing Then
 Dim lr2 As Long, c As Long, targets As Variant, tCol As Long, colOK As Boolean
 lr2 = GetLastRowInWs(ws2): targets = Split(TARGET_COL, ",")
 With ws1.UsedRange
 For c = START_COL To lc1
 For tCol = 0 To UBound(targets)
 If InStr(1, .Columns(c).Cells(1), targets(tCol)) > 0 Then
 .Columns(c).Hidden = False
 .SpecialCells(xlCellTypeVisible).Copy ws2.Cells(lr2, 1)
 .Columns(c).Hidden = True
 lr2 = ws2.UsedRange.Rows.Count + 1
 Exit For
 End If
 Next
 Next
 .Columns.Hidden = False: ws2.UsedRange.EntireColumn.AutoFit: ws2.Activate
 End With
 End If
 optimizeXL False
End Sub

Helpers:

Private Function GetWs2(ByVal wsName As String, ByRef AfterWs As Worksheet) As Worksheet
 If Len(wsName) > 0 And Not AfterWs Is Nothing Then
 If Not WSExists(wsName) Then
 Set GetWs2 = ThisWorkbook.Worksheets.Add(After:=AfterWs)
 GetWs2.Name = wsName
 Else
 Set GetWs2 = ThisWorkbook.Worksheets(wsName)
 End If
 End If
End Function
Private Function GetLastRowInWs(ByRef ws As Worksheet) As Long
 If Not ws Is Nothing Then
 With ws.UsedRange
 GetLastRowInWs = .Rows.Count
 If GetLastRowInWs > 1 Then
 .Rows.EntireRow.Delete
 GetLastRowInWs = ws.UsedRange.Rows.Count
 End If
 End With
 End If
End Function

---

Public Function WSExists(ByVal wsName As String) As Boolean
 If Len(wsName) > 0 Then
 Dim ws As Worksheet
 For Each ws In ThisWorkbook.Worksheets
 If ws.Name = wsName Then
 WSExists = True
 Exit Function
 End If
 Next
 End If
End Function
Public Sub optimizeXL(Optional ByVal settingsOff As Boolean = True)
 With Application
 .ScreenUpdating = Not settingsOff
 .Calculation = IIf(settingsOff, xlCalculationManual, xlCalculationAutomatic)
 .EnableEvents = Not settingsOff
 End With
End Sub

---

Sheet1:

Sheet1

Output:

Sheet2

---

At high level the code works by hiding all columns, except the first.

It loops all other columns (starting at col 2):

1. Check header of the currently processed column and if valid
   • Unhides current col (we now have col1 and col2 visible)
   • Copies the 2 visible columns to result sheet, in first empty cell in column A
   • Hides the current column
2. Moves to the next column and repeats the steps above (1.)

---

Step by step

• Pinlop: You are right, the code is supposed to copy the columns based on the column names. In the example I had, the code is looking for "iq_9" (pptText)and so it will extract every column with "iq_9" in the title and stack them. This is why the first column wasn't copied over, it's an "iq_7".
• Pinlop: So a regular number is written like this "iq_10_01__A_" and I'll store each value into a four slotted array. So then in slot 2 (iQRefArray(1)) I'll look for the 10 and if slot 3 = 00 it means this is the only "iq_" of this number, if slot 3 = 01 it means that there is another one coming after it = "iq_10_02__A_". So I'll check to see if the 3rd array slot in the next "iq_" = 00 or 01 to find the end of the sequence and end the loop. I hope this helps, ask me any more clarification and I will try my best!