VBA code, select conditional formatting content and transpose Sorted to other sheet

Hi David,

I wrote it step by step and commented rather well so hope it is rather easy to understand.

first main working procedure:

Sub copy_selected_from_column(input_col As Long)
Dim i As Long, j As Long, output_row As Long, output_string As String, table(1 To 5) As Integer
'first check if there are 5 Y's
If Application.WorksheetFunction.CountIf(Sheets("R-2").Cells(3, input_col).Resize(36, 1), "Y") <> 5 Then
  'alert if not 5 and do nothing
  MsgBox "Please select EXACTLY five Y's in " & Cells(3, input_col).Resize(36, 1).Address
Else
  ' collect all selected numbers in one table
  ' start from table(1)
  j = 1
  'go through all 36 rows
  For i = 1 To 36
    'and check if ther is Y mark
    If Sheets("R-2").Cells(2 + i, input_col) = "Y" Then
      'if found write to table number from 2 columns left
      table(j) = CInt(Sheets("R-2").Cells(2 + i, input_col - 2))
      'and advance to next position in a table
      j = j + 1
    End If
  Next i
  'now in the table are 5 numbers in standard order
  'we will use worksheet function SMALL to sort them ascending in output string
  'so for smallest = small(xxxxx,1) to largest = "least small of 5" small(xxxxx,5)
  'let's start with empty string
  output_string = "" 'added only for clarity - this string is empty anyway
  For j = 1 To 5
    'to existing output_string add formatted as 2digit j-th smallest number and dash
    output_string = output_string & Format(Application.WorksheetFunction.Small(table, j), "00") & "-"
  Next j
  'remove dash after last number
  output_string = Left(output_string, Len(output_string) - 1)
  'find empty row in T-2
  output_row = Sheets("T-2").Range("I3").End(xlDown).Row + 1
  'write in that row header from R2 row 2 and output_string
  Sheets("T-2").Range("I" & output_row) = "R-2 " & Sheets("R-2").Cells(2, input_col - 2)
  Sheets("T-2").Range("J" & output_row) = output_string
End If
End Sub

As you can see it has one argument so cannot be called directry from the worksheet/button but has to be called from other procedure. for instance clear all in T-2!I5:J29 and call:

Sub test()
' the only action is to call working procedure passing into it argument = 3 i.e. column C 
Call copy_selected_from_column(3)
End Sub

(both test() and copy_selected_from_column(input_col As Long) procedures shall be in standard module - can be the same or different modules - does not matter).

If you are satisfied with the result, clear T-2!I5:J29 again and call next procedure (again inserted in standard module):

Sub test2()
Dim i As Long
'now let's do it in a loop for each third column: C, F, I, etc.
For i = 3 To 27 Step 3
  Call copy_selected_from_column(i)
Next i
End Sub

Note that in your sample data you had no Y's for Zone2 - you will get a message box that there was no five Y's in F3:F38.

Best Regards,

Hi David.
Run the code and see if that is what you were trying to achieve...

Sub Test2()
Dim i As Long
'now let's do it in a loop for each third column: C, F, I, etc.
For i = 3 To 27 Step 3
  Call copy_selected_from_column(i)
Next i
End Sub

Sub copy_selected_from_column(input_col As Long)
Dim i As Long, j As Long, output_row As Long, output_string As String, table(1 To 5) As Integer
If Application.WorksheetFunction.CountIf(Sheets("R-2").Cells(3, input_col).Resize(36, 1), "Y") <> 5 Then
  MsgBox "Please select EXACTLY five Y's in " & Cells(3, input_col).Resize(36, 1).Address
Else
  j = 1
  For i = 1 To 36
    If Sheets("R-2").Cells(2 + i, input_col) = "Y" Then
      table(j) = CInt(Sheets("R-2").Cells(2 + i, input_col - 2))
      j = j + 1
    End If
  Next i
  output_string = "" 'added only for clarity - this string is empty anyway
  For j = 1 To 5
    output_string = output_string & Format(Application.WorksheetFunction.Small(table, j), "00") & "-"
  Next j
  output_string = Left(output_string, Len(output_string) - 1)
  output_row = Sheets("T-2").Range("I3").End(xlDown).Row + 1
  Sheets("T-2").Range("I" & output_row) = "R-2 " & Sheets("R-2").Cells(2, input_col - 2)
  Sheets("T-2").Range("J" & output_row) = output_string
End If
End Sub

Check the attached file..

Okay a little change ( I hope I have understand your code as you did )

Sub Test2()
Dim i As Long
'now let's do it in a loop for each third column: C, L, U, etc.
For i = 3 To 81 Step 9
  Call copy_selected_from_column(i)
Next i
End Sub

The following code has not been changed... ( I don't think it need to ..)

Sub copy_selected_from_column(input_col As Long)
Dim i As Long, j As Long, output_row As Long, output_string As String, table(1 To 5) As Integer
If Application.WorksheetFunction.CountIf(Sheets("R-2").Cells(3, input_col).Resize(36, 1), "Y") <> 5 Then
  MsgBox "Please select EXACTLY five Y's in " & Cells(3, input_col).Resize(36, 1).Address
Else
  j = 1
  For i = 1 To 36
    If Sheets("R-2").Cells(2 + i, input_col) = "Y" Then
      table(j) = CInt(Sheets("R-2").Cells(2 + i, input_col - 2))
      j = j + 1
    End If
  Next i
  output_string = "" 'added only for clarity - this string is empty anyway
  For j = 1 To 5
    output_string = output_string & Format(Application.WorksheetFunction.Small(table, j), "00") & "-"
  Next j
  output_string = Left(output_string, Len(output_string) - 1)
  output_row = Sheets("T-2").Range("I3").End(xlDown).Row + 1
  Sheets("T-2").Range("I" & output_row) = "R-2 " & Sheets("R-2").Cells(2, input_col - 2)
  Sheets("T-2").Range("J" & output_row) = output_string
End If
End Sub

Regards,

Hi David,

The code you mentioned:

For i = 22 To 102 Step 9  '( it was 3 To 27 Step 3)

shall work fine with data in columns V, AE, AN,... etc. Are columns names (letters) corrrect?
How about rows: Does data in R-2 sheet starts in row 3 and extends 36 rows down?
is the data to be collected (marked with Y in column V, AE, ...) located in second column left from column with Ys?
this second left is used here:

table(j) = CInt(Sheets("R-2").Cells(2 + i, input_col - 2))

so as it is above, it takes values from columns T, AC, AL, ... (when there is Y in column V, AE, AN, ...)

If you would rather like to have values from N, W, AF,.... then change this line to:

table(j) = CInt(Sheets("R-2").Cells(2 + i, input_col - 8))

Hope it helps,

Hi kaper,

I don't know how to use an easy explanation, but let me try..


I'm going to use the same code 4 times to grab Y'S from 4 different columns for each steps.
The code work fine when (first zone or first 9 column at the left on sample file)
For example from 9 steps, lets concentrate in only 1 (first Step)
-.String are in AB3:AB38
-.The first sets of Y's are in AD3:AD38
-.The Heading Id are located in AB2
at this point the Code work perfect, it export to sheet T-2 the String marked with Y'S and heading ID !!

But Now, on same First Step (of 9) i need to do the same as above but using same Column string (AB3:AB38)
and different column with Y'S and heading

-.Use same String AB3:AB38
with
-.Use Y'S from AF3:AF38
-.Use AE2 heading Id

Then

-.Use same String AB3:AB38
with
-.Use Y'S from AH3:AF38
-.Use AG:2 heading Id

and finally

-.Use same String AB3:AB38
with
-.Use Y'S from AJ3:AF38
-.Use AI:2 heading Id

So the question is : which line value do i have to change to achieve this?


Thank you !

David

Hi,
As AD is column 30, and AF is column 32 you shall in Sub Sel_Second_Right_Y
make your loop:

For i = 32 To 137 Step 9 ' not 30 To 135 Step 9

then corrected code in Sub copy_selected_from_column_2 would be:

    table(j) = CInt(Sheets("R-2").Cells(2 + i, input_col - 4))

note: inputcol - 4 because inputcol is 32 (AF) while numbers are from AB (AF-4) and header shall be from AE (so inputcol-1):

Sheets("T-2").Range("I" & output_row) = "R-2 " & Sheets("R-2").Cells(2, input_col - 1)

of course for third similar (in Sub Sel_Third_Right_Y):

For i = 34 To 139 Step 9

then in copy_selected_from_column_3:

   table(j) = CInt(Sheets("R-2").Cells(2 + i, input_col - 6))

and exactly the same as above:

Sheets("T-2").Range("I" & output_row) = "R-2 " & Sheets("R-2").Cells(2, input_col - 1)

Probably I do not have to write it, that for fourth

For i = 36 To 141 Step 9

and

   table(j) = CInt(Sheets("R-2").Cells(2 + i, input_col - 8))

would do the job.

This approach is implemented in first attached file. But as we do all the time the same (side comment - would be even easier if columns AB and AC, AK and AL etc were in oposite sequence, we could skip all that play with offset_to_header and where_header variables), it is wise to do all actions within another loop. For instance:

Sub Sel_All_Four_Right_Y()
Dim i As Long, j As Integer, where_header As Integer
For j = 1 To 4
  If j = 1 Then
    where_header = 2
  Else
    where_header = 1
  End If
  For i = 28 To 133 Step 9
    Call copy_selected_from_column_X(i + 2 * j, 2 * j, where_header)
  Next i
Next j
End Sub

Sub copy_selected_from_column_X(input_col As Long, offset_to_numbers As Integer, offset_to_header As Integer)
Dim i As Long, j As Long, output_row As Long, output_string As String, table(1 To 5) As Integer
If Application.WorksheetFunction.CountIf(Sheets("R-2").Cells(3, input_col).Resize(36, 1), "Y") <> 5 Then
   MsgBox "Please select EXACTLY five Y's in " & Cells(3, input_col).Resize(36, 1).Address
Else
   j = 1
   For i = 1 To 36 'Start Column 1 to 108 Correct for my new release Tab R-2
   If Sheets("R-2").Cells(2 + i, input_col) = "Y" Then
   table(j) = CInt(Sheets("R-2").Cells(2 + i, input_col - offset_to_numbers))
      j = j + 1
    End If
  Next i
   output_string = "" 'added only for clarity - this string is empty anyway
  For j = 1 To 5
   output_string = output_string & Format(Application.WorksheetFunction.Small(table, j), "00") & ","
  Next j
   output_string = Left(output_string, Len(output_string) - 1)
   output_row = Sheets("T-2").Range("I3").End(xlDown).Row + 1
   Sheets("T-2").Range("I" & output_row) = "R-2 " & Sheets("R-2").Cells(2, input_col - offset_to_header)
  Sheets("T-2").Range("J" & output_row) = output_string
End If
End Sub

This approach is used in second file. Results are the same, but this second one is much more compact and easier to correct if for some reason input data layout changes somewhat.

Zones_K32.xlsb Here's the R-2 with added columns.

Sub test2()
Dim i As Long, j As Long
'now let's do it in a loop for each third column: C, F, I, etc.
For j = 30 To 382 Step 32
For i = 0 To 29
  Call copy_selected_from_columnNew(i + j, i)
Next i
Next j
End Sub

Sub copy_selected_from_columnNew(input_col As Long, offset As Long): Dim output_string2 As String
Dim i As Long, j As Long, output_row As Long, output_string As String, table(1 To 5, 0 To 1) As Integer
'first check if there are 5 Y's
If WorksheetFunction.CountIf(Sheets("N-1").Cells(3, input_col).Resize(36, 1), "Y") <> 5 Then
  'alert if not 5 and do nothing
  'MsgBox "Please select EXACTLY five Y's in " & Cells(3, input_col).Resize(36, 1).Address
Else
  ' collect all selected numbers in one table
  ' start from table(1)
  j = 1
  'go through all 36 rows
  For i = 1 To 36
    'and check if ther is Y mark
    If Sheets("N-1").Cells(2 + i, input_col) = "Y" Then
      'if found write to table number from 2 columns left
      table(j, 0) = CInt(Sheets("N-1").Cells(2 + i, input_col - 2 - offset))
      table(j, 1) = CInt(Sheets("N-1").Cells(2 + i, input_col - 1 - offset))
      'and advance to next position in a table
      j = j + 1
    End If
  Next i
  'now in the table are 5 numbers in standard order
  'we will use worksheet function SMALL to sort them ascending in output string
  'so for smallest = small(xxxxx,1) to largest = "least small of 5" small(xxxxx,5)
  'let's start with empty string
  output_string = "" 'added only for clarity - this string is empty anyway
  output_string2 = ""
  For j = 1 To 5
    'to existing output_string add formatted as 2digit j-th smallest number and dash
    output_string = output_string & table(j, 0) & "-"
    output_string2 = output_string2 & table(j, 1) & "-"
  Next j
  'remove dash after last number
  output_string = Left(output_string, Len(output_string) - 1)
  output_string2 = Left(output_string2, Len(output_string2) - 1)
  'find empty row in T-2
  output_row = Sheets("TICKETS").Range("I3").End(xlDown).Row + 1
  'write in that row header from R2 row 2 and output_string
  Sheets("TICKETS").Range("I" & output_row) = "N-1 " & Sheets("N-1").Cells(2, input_col)
  Sheets("TICKETS").Range("I" & output_row + 1) = "Score"
  Sheets("TICKETS").Range("J" & output_row) = output_string
  Sheets("TICKETS").Range("J" & output_row + 1) = output_string2
End If
End Sub

Hi David,


These will get you the score line but I've lost the numerical order for the Ticket

Hi XLAdept,

I ran the code, and the numbers marked with Y's are copied correct to sheet 'Tickets'
that's all, is exactly what i was in need (to modify) and You did't

Except :
-the word 'score' and the 'string' not going in Sheet tickets.
-need the numbers sorting with a leading '00'

I'm going to study Kaper code and yours because I'm curious about where was the point where i was failing, and i'm going to learn from your expertise for near future




best regards

David

Hi David,

Good for you - I'll look at the exception tomorrow

Orrin

Hi David,


I've formatted the output the way Kaper did and I've sorted the output - if you don't want the scores posted then just comment out the red lines

Sub copy_selected_from_columnNew(input_col As Long, offset As Long): Dim output_string2 As String, N, S, Z
Dim i As Long, j As Long, output_row As Long, output_string As String, table(1 To 5, 0 To 1) As Integer
'first check if there are 5 Y's
If WorksheetFunction.CountIf(Sheets("N-1").Cells(3, input_col).Resize(36, 1), "Y") <> 5 Then
  'alert if not 5 and do nothing
  'MsgBox "Please select EXACTLY five Y's in " & Cells(3, input_col).Resize(36, 1).Address
Else
  ' collect all selected numbers in one table
  ' start from table(1)
  j = 1
  'go through all 36 rows
  For i = 1 To 36
    'and check if ther is Y mark
    If Sheets("N-1").Cells(2 + i, input_col) = "Y" Then
      'if found write to table number from 2 columns left
      table(j, 0) = CInt(Sheets("N-1").Cells(2 + i, input_col - 2 - offset))
      table(j, 1) = CInt(Sheets("N-1").Cells(2 + i, input_col - 1 - offset))
      'and advance to next position in a table
      j = j + 1
    End If
  Next i
  'now in the table are 5 numbers in standard order
   
  output_string = "" 'added only for clarity - this string is empty anyway
  output_string2 = ""
  For j = 1 To 5
    'to existing output_string add formatted as 2digit j-th smallest number and dash
    
    output_string = output_string & Format(table(j, 0), "00") & "-"
    output_string2 = output_string2 & Format(table(j, 1), "00") & "-"
  Next j
  'remove dash after last number
  output_string = Left(output_string, Len(output_string) - 1)
  output_string2 = Left(output_string2, Len(output_string2) - 1)
  N = Split(output_string, "-"): S = Split(output_string2, "-")
  
Bubble:  For j = 0 To 3
            If N(j) > N(j + 1) Then
        Z = N(j): N(j) = N(j + 1): N(j + 1) = Z
        Z = S(j): S(j) = S(j + 1): S(j + 1) = Z
            GoTo Bubble: End If: Next j
  output_string = Join(N, "-"): output_string2 = Join(S, "-")
  
  'find empty row in T-2
  output_row = Sheets("TICKETS").Range("I3").End(xlDown).Row + 1
  'write in that row header from R2 row 2 and output_string
  Sheets("TICKETS").Range("I" & output_row) = "N-1 " & Sheets("N-1").Cells(2, input_col)
  Sheets("TICKETS").Range("I" & output_row + 1) = "Score"
  Sheets("TICKETS").Range("J" & output_row) = output_string
  Sheets("TICKETS").Range("J" & output_row + 1) = output_string2
End If
End Sub

Hi David,

This code is from Post#15:

Sub test2()
Dim i As Long, j As Long
'now let's do it in a loop for each third column: C, F, I, etc.
For j = 30 To 382 Step 32
For i = 0 To 29
  Call copy_selected_from_columnNew(i + j, i)
Next i
Next j
End Sub

Hi David,

No - not dumb - we all have these moments, all of us who can be intent on our objective anyway