PDA

View Full Version : Cycle thru worksheets and import shape according to dynamic values



thole
05-08-2009, 09:18 AM
I have a workbook with blue-tabbed wkshts and red-tabbed wkshts.
I would like to cycle through the red-tabbed worksheets, and if the value of Range AH is the same as the name of one of the blue-tabbed worksheets, import the shape named "linedrawing" from that worksheet.
Repeat until done.
All the blue-tabbed worksheets have the exact same formatting, the shape is actually a picture, and it has the same position and same name in all the different blue-tabbed sheets.

What I have so far (which absolutely is off in another galaxy) is:


Sub CopyDrawings()

Dim shp As Shape
Dim ws As Worksheet

For Each ws In ActiveWorkbook.Sheets

'If ws.Tab.ColorIndex = 3 Then

ws.Activate

For Each c In ActiveSheet.Range("$AH$50:$AH$2000")
If c.Value = ws.Name Then
ws.shp("linedrawing").Select
Selection.Copy
c.Offset(rowOffset:=0, columnOffset:=-31).Select
ActiveSheet.Paste
MsgBox "OK?"
End If
Next
End If
Next

End Sub

I know i am not selecting things properly.

I had posted it on another site, got no help, closed it down.

georgiboy
05-08-2009, 09:38 AM
I would imagine a sample workbook would give you a better chance finding a solution to this problem.

Bob Phillips
05-08-2009, 10:06 AM
Sub CopyDrawings()
Const MATCH_FORMULA As String = _
"MATCH(TRUE,ISNUMBER(MATCH('<ws>'!H5:H20,{""<names>""},0)),0)"
Dim VecBlue As Variant
Dim shp As Shape
Dim ws As Worksheet
Dim RowNum As Long
Dim SheetNames As String
Dim i As Long

ReDim VecBlue(1 To ActiveWorkbook.Worksheets.Count)
For Each ws In ActiveWorkbook.Worksheets

If ws.Tab.ColorIndex = 5 Then

i = i + 1
VecBlue(i) = ws.Name
End If
Next ws
ReDim Preserve VecBlue(1 To i)

SheetNames = Join(VecBlue, ",")
SheetNames = Replace(SheetNames, ",", """,""")

For Each ws In ActiveWorkbook.Worksheets

If ws.Tab.ColorIndex = 3 Then

On Error Resume Next
RowNum = ws.Evaluate(Replace(Replace(MATCH_FORMULA, "<names>", SheetNames), "<ws>", ws.Name))
On Error GoTo 0
If RowNum > 0 Then

Worksheets(ws.Range("H5:H20").Cells(RowNum).Value).Shapes("linedrawing").Copy
ws.Activate
Cells(ws.Range("H5:H20").Cells(RowNum).Row, "C").Select
ActiveSheet.Paste
End If
End If
Next ws
End Sub

thole
05-08-2009, 12:46 PM
Works extremely well, except I forgot to mention I need to cycle through the Range - right now it only imports the first value it finds in the Range AH5:AH20 I need to import the shapes if c.value<>""