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

BuRnZz

New Member
Joined
Dec 9, 2020
Messages
27
Office Version
  1. 365
  2. 2016
  3. 2013
Platform
  1. Windows
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:

cK2pL.png


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.

VBA Code:
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!
 
Problem solved with a little helper function to check the last row filled and if thats row 2, set lr to 1:

VBA Code:
For Each WrkSht In WrkShtCol

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

Excel Facts

Using Function Arguments with nested formulas
If writing INDEX in Func. Arguments, type MATCH(. Use the mouse to click inside MATCH in the formula bar. Dialog switches to MATCH.

Forum statistics

Threads
1,214,387
Messages
6,119,222
Members
448,877
Latest member
gb24

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top