VBA: Loop through Range, If Value = “x” Copy Value from Cell 8 Columns to the right of it to other Worksheet

[BuRnZz]

I have a questionnaire-table where for each question (one question per row), an "x" can be set in Columns C through F, each of them indicating a different answer (C = worst, F = best). To the right of that table in Colum L through O are sentences, each according to the answers in the columns on the left.
If there is an "x" in one Cell, I want the according sentence from the right side to be copied to another Worksheet named "Textboxes", basically allowing me to create one worksheet with all the sentences from the answers of the questionnaire. This whole table looks like this:

The Sentences on the right are 9 columns to the right to each answer on the left, meaning if the X is in column C (worst answer) the according sentence that needs to be copied is 9 columns to the right, in column L. If the X is in column D, the sentence from the cell 9 columns to the right (column M) would need to be copied and so on.


So far Ive written this Module to help copy the according sentences into the destination-worksheet named "Textboxes" but it's nor working at all.

Option Explicit
Dim cell As range
Dim range As range
Dim Workbook As Worksheet

Sub Textboxes()


'New Worksheet
Sheets.Add
'Change Name
ActiveSheet.Name = "Textboxes"


Set range = Sheets("Questionnaire1").range("C11:F113") 'C11:F13 is the range where the answers/X's could be in 

For Each cell In range

If cell.Value = "x" Then
ActiveCell.Offset(0, 8).Activate
ActiveCell.Copy (Sheets("Textboxes").range("A1"))


End If

Next cell

End Sub

So basically the idea / desired behaviour is:
-loop through the table
-if Cell has an "x" move 9 cells to the right to find the desired sentence
-copy the sentence from that cell to the worksheet "Textboxes" (Ideally first sentence in A1, second in A2... right now everything goes into A1 but I cant even get that to work)

Thank you so much for you help and feedback, I hope I gave good information for you to understand the problem. Thank you in advance!

 

[Norie]

Your initial loop should be through the rows, you should then loop through each cell in the row and when you find an X you can do the copying.

Something like this.

Option Explicit

Sub Textboxes()
Dim rw As Range
Dim cell As Range

    'New Worksheet
    Sheets.Add
    'Change Name
    ActiveSheet.Name = "Textboxes"

    For Each rw In Sheets("Questionnaire1").Range("C11:F113").Rows
        For Each cl In rw.Cells
            If LCase(cell.Value) = "x" Then
                cell.Offset(0, 8).Copy Sheets("Textboxes").Range("A" & Rows.Count).End(xlUp).Offset(1)
            End If
        Next cl
    Next Row

End Sub

 

[Rick Rothstein]

Wow, all kinds of problems with this thread. The OP's description of "8 Columns to the right" doesn't match the picture he posted (Column L is 9 columns to the right of Column C). Norie's code has some problems as well (I'm assuming from some last minute edits)... it declares Cell as a variable but sometimes uses cl instead and it declares rw as a variable but uses Row on the final Next statement.

Assuming the OP's picture is correct (data starts on Row 4, not Row 11 and Column L is the first data cell with sentences), here is a macro that should work (note, unlike Norie's code, my code assumes a sheet named Textboxes already exists)...

Sub Textboxes()
  Dim Rw As Range
  For Each Rw In Sheets("Questionnaire1").Range("C4:F" & Sheets("Questionnaire1").Cells(Rows.Count, "B").End(xlUp).Row).Rows
    Rw.SpecialCells(xlConstants).Offset(, 9).Copy Sheets("Textboxes").Cells(Rows.Count, "A").End(xlUp).Offset(1)
  Next
End Sub

 

[Norie]

Rick

Think I got a bit muddled up trying to get Range to capitalize after the original code used 'range' as a variable name.

Also, didn't check the offset as it looked kind of right.

 

[BuRnZz]

Your initial loop should be through the rows, you should then loop through each cell in the row and when you find an X you can do the copying.

Something like this.

Option Explicit

Sub Textboxes()
Dim rw As Range
Dim cell As Range

    'New Worksheet
    Sheets.Add
    'Change Name
    ActiveSheet.Name = "Textboxes"

    For Each rw In Sheets("Questionnaire1").Range("C11:F113").Rows
        For Each cl In rw.Cells
            If LCase(cell.Value) = "x" Then
                cell.Offset(0, 8).Copy Sheets("Textboxes").Range("A" & Rows.Count).End(xlUp).Offset(1)
            End If
        Next cl
    Next Row

End Sub

Thanks this has helped me a lot!

 

[BuRnZz]

Thank you guys, your Code has helped me achieve my goal. Only 1 tiny problem is that all the Information gets pasted into A2 as the first row, then A3 and so on, but I really need A1 to be the first cell to be filled. Would you guys may be able to figure out why that is?

 

[BuRnZz]

Thank you guys, your Code has helped me achieve my goal. Only 1 tiny problem is that all the Information gets pasted into A2 as the first row, then A3 and so on, but I really need A1 to be the first cell to be filled. Would you guys may be able to figure out why that is?

Ok this is due to the ".Offset(1)" at the end of both code segements. I need this to paste into one row and then the one below etc. but can I somehow still start at A1 not A2?

 

[Norie]

Create a range variable that points to the row A1 in the destination sheet, as you go through the rows offset that by 1 row each time.

Sub Textboxes()
Dim rngDst As Range
Dim rw As Range
Dim cl As Range

    'New Worksheet
    Sheets.Add
    'Change Name
    ActiveSheet.Name = "Textboxes"

    Set rngDst = ActiveSheet.Range("A1")
   
    For Each rw In Sheets("Questionnaire1").Range("C11:F113").Rows
        For Each cl In rw.Cells
            If LCase(cl.Value) = "x" Then
                cl.Offset(0, 8).Copy rngDst
                Set rngDst = rngdst.Offset(1)
            End If
        Next cl
    Next Row

End Sub

 

[Rick Rothstein]

Alternately, just delete cell A1 before exiting the macro by adding this line of code...

Sheets("Textboxes").Range("A1").Delete xlShiftUp

Note to Norie: You used "Row" on your last Next statement instead of "rw" and an offset of 8 rather than 9.

 

[BuRnZz]

Create a range variable that points to the row A1 in the destination sheet, as you go through the rows offset that by 1 row each time.

Sub Textboxes()
Dim rngDst As Range
Dim rw As Range
Dim cl As Range

    'New Worksheet
    Sheets.Add
    'Change Name
    ActiveSheet.Name = "Textboxes"

    Set rngDst = ActiveSheet.Range("A1")
  
    For Each rw In Sheets("Questionnaire1").Range("C11:F113").Rows
        For Each cl In rw.Cells
            If LCase(cl.Value) = "x" Then
                cl.Offset(0, 8).Copy rngDst
                Set rngDst = rngdst.Offset(1)
            End If
        Next cl
    Next Row

End Sub

This sadly doesnt work I think, heres my current code for looping:

Set WrkShtCol = Worksheets(Array("AM AD - Anforderungsdefinition", "AM AA - Anforderunganalyse"))
    
For Each WrkSht In WrkShtCol

    For Each rw In WrkSht.range(Antwortrange).Rows   'Reihen durchlaufen innerhalb der Antwortrange
        For Each cl In rw.Cells
            If LCase(cl.Value) = "x" Then
                cl.Offset(0, 9).Copy Sheets("Handlungsempfehlungen").range("A" & Rows.Count).End(xlUp).Offset(1)       'Jede Zelle mit Value "x" 9 Spalten nach rechts auswählen (Handlungsempfehlung), weitergeben
            End If
        Next cl
    Next rw

The Thing is it is set to A1 I believe (or if not "set" it still chooses A1) but then because of the Offset goes one down, but I still need the offset or otherwise It would all be copied to the same cell.
Maybe Im overlooking something.