get cell value where offset cell = X, use this value to populate list

[CJ]

Example:

Sheet"xyz"
A B C D E F G H I
r x
s x
t x

Sheet"Titles"
A B C D E F G H I
r
s
t


IF worksheet name <> "Titles" and value in column G = "x" THEN
for that same row, get the cell value in column D, and populate a
list in column A on worksheet name = "Titles"


THANK YOU for your help! I'm stuck.

 

[Mike H]

CJ,

Alt + F11 to open VB editor, right click 'This Workbook' and insert module,
paste this in and run it.

Sub copyit()
Dim MyRange, MyRange1 As Range
lastrow = Cells(Rows.Count, "G").End(xlUp).Row
Set MyRange = Sheets("xyz").Range("G1:G" & lastrow)
Sheets("xyz").Select
For Each c In MyRange
If UCase(c.Value) = "X" Then
If MyRange1 Is Nothing Then
Set MyRange1 = c.Offset(, -6)
Else
Set MyRange1 = Union(MyRange1, c.Offset(, -6))
End If
End If
Next
If Not MyRange1 Is Nothing Then
MyRange1.Select
Selection.Copy
Sheets("Titles").Select
Range("A1").Select
ActiveSheet.Paste
End If
End Sub

Mike

 

[Mike H]

OOPS,

the offset is -3 not minus -6 you wanted to copy column D

Mike

 

[CJ]

Thanks Mike! This worked for me below! Can you help me get this to
run for every worksheet in the active workbook where worksheet.name <>
"TOC" or <> "List"? Then with the data generated for each MyRange1, on
the "Title" worksheet append it to the next available row column A.
(Maybe leaving a space between each)


---------------------------------
Sub copyit()
Dim MyRange, MyRange1 As Range
lastrow = Cells(Rows.Count, "G").End(xlUp).Row
Dim c As Range
Set MyRange = Sheets("xyz").Range("G12:G" & lastrow)
Sheets("xyz").Select

For Each c In MyRange
If c.Value = "Status:" Then
If MyRange1 Is Nothing Then
Set MyRange1 = c.Offset(, -3)
Else
Set MyRange1 = Union(MyRange1, c.Offset(, -3))
End If
End If
Next

If Not MyRange1 Is Nothing Then
MyRange1.Select
Selection.Copy
Sheets("Title").Select
Range("A1").Select
ActiveSheet.Paste
End If

End Sub

 

[Mike H]

As soon as I re-read your post i suspected you wanted it for every sheet so
try this

Sub copyit()
Dim MyRange, MyRange1 As Range
Dim ws As Worksheet
x = 1
For Each ws In ThisWorkbook.Worksheets
Worksheets(x).Select
If ws.Name <> "Titles" And ws.Name <> "TOC" Then
lastrow = Cells(Rows.Count, "G").End(xlUp).Row
Set MyRange = Worksheets(x).Range("G1:G" & lastrow)
For Each c In MyRange
If UCase(c.Value) = "X" Then
If MyRange1 Is Nothing Then
Set MyRange1 = c.Offset(, -3)
Else
Set MyRange1 = Union(MyRange1, c.Offset(, -3))
End If
End If
Next
End If
If Not MyRange1 Is Nothing Then
MyRange1.Select
Selection.Copy
Sheets("Titles").Select
Cells(Cells(Rows.Count, "A").End(xlUp).Row, 1).Select
ActiveSheet.Paste
End If
x = x + 1
Set MyRange1 = Nothing
Next
Application.CutCopyMode = False
End Sub

Mike

 

[Mike H]

I forgot the space between the rows add this line between the 2 existing lines

Cells(Cells(Rows.Count, "A").End(xlUp).Row, 1).Select

If ActiveCell.Row <> 1 Then ActiveCell.Offset(2, 0).Select 'new line

ActiveSheet.Paste

Mike

 

[CJ]

I get an error upon running for:

Selection.Copy

"That command cannot be used on multiple selections."

 

[CJ]

I get and error on

Selection.Copy

"cannot be used on multiple selections"

 

[CJ]

I get an error upon running for:

Selection.Copy

"That command cannot be used on multiple selections."

This seems like it could be related to some of the columns with value
'X' are merged and others are not.