Reference to variable Cell Image to Other sheet

S

sureshtrb

Board Regular
Joined
Mar 24, 2013
Messages
106
Recalling data in userform from excel saved data, data works and image (Saved in cell) also works if I refer
Code: 
Set CopyImage1 = Worksheets("Data").Range("QW14")
I don't want to refer a particular cell the range should be variable like
Code: 
Set CopyImage1 = Worksheets("Data").Range(Foundcell.offset(0,464))
Unable to achieve this.
Any help is appreciated.
Thanks
 
Sort by date Sort by votes
Where's the code that uses CopyImage1?
 
Upvote 0

Excel Facts

Wildcard in VLOOKUP
Use =VLOOKUP("Apple*" to find apple, Apple, or applesauce
Part of the code:
Code: 
Private Sub btnSearch_Click()Call ClearClipboard
            Me.btnSearch.Visible = True
            Me.CBSearchCatagory.Visible = True
            Me.CBSearchResult.Visible = True
            Me.cmdUpdate.Visible = True
            Me.cmdAdd.Visible = True
Dim FoundCell As Range
    If Me.CBSearchResult.Value = "" Then
        Me.tbCVCNo.Enabled = True
    With Me.CBSearchResult
        End With
            If Me.CBSearchCatagory.Value = "Search by CVC Number" Or _
                Me.CBSearchCatagory.Value = "Search by Nasico UID Number" Or _
                Me.CBSearchCatagory.Value = "Search by Tag Number" Or _
                Me.CBSearchCatagory.Value = "Search by Customer" Or _
                Me.CBSearchCatagory.Value = "Search by Valve Manufacturer" Or _
                Me.CBSearchCatagory.Value = "Search by Job Number" And _
                Me.CBSearchResult = "" Then Exit Sub
                Me.CBSearchResult.Visible = True
            End If
                If Me.CBSearchResult.ListIndex = 0 Then
                        Beep
                            Exit Sub
                End If
            If Me.CBSearchCatagory.Value = "Search by CVC Number" And Me.tbCVCNo.Value = Me.CBSearchResult Then
                With CBSearchResult
                 Application.ScreenUpdating = False
                        Set FoundCell = Cells.Find(what:=Me.CBSearchResult.Value, _
                                                            After:=Cells(1), _
                                                            LookIn:=xlValues, _
                                                            lookat:=xlWhole, _
                                                            SearchOrder:=xlByRows, _
                                                            SearchDirection:=xlPrevious, _
                                                            MatchCase:=False)
        If Not FoundCell Is Nothing Then
            Beep
Me.tbUIDNO.Value = FoundCell.Offset(0, 1).Value
Me.tbTAGNO.Value = FoundCell.Offset(0, 2).Value
Me.tbCUSTOMER.Value = FoundCell.Offset(0, 3).Value
'...............
'........
'......
'...


If FoundCell.Offset(0, 463).Value = "AFO" Then Me.OptionButton72.Value = True
If FoundCell.Offset(0, 463).Value = "AFC" Then Me.OptionButton73.Value = True
  
  
  Call ClearClipboard
           'Picture1-Comment Copy to userform
'Picture1-Label Copy to userform
Dim wsImageCopies1, wsinit1 As Worksheet
Dim oImage As image
Dim oShape, CopyImage1, PasteImage1 As shape
Dim oChart As Chart
Dim sTempFilename1, strInitDir1 As String
Dim s As Double
Dim l As Double
Dim t As Double
Dim h As Double




'Assign a filename for the temporary image
sTempFilename1 = Environ("temp") & "\temp_" & Format(Now, "yy-mm-dd_hh-mm-ss") & ".jpg"


'Dim s, l, t, h As Long
s = 260
t = 100
l = 24
h = 24




If FoundCell.Offset(0, 484).Text > 0 Then


Set wsinit1 = ActiveSheet
strInitDir1 = CurDir   'Optional: Save directory so can return to it.


Call ClearClipboard


'Test if "ImageCopies" worksheet exists and if not then add it
On Error Resume Next
Set wsImageCopies1 = Nothing  'Initialize first
Set wsImageCopies1 = Worksheets("ImageCopies1")
If wsImageCopies1 Is Nothing Then
Set wsImageCopies1 = Sheets.Add(After:=Sheets(Sheets.Count))
wsImageCopies1.Name = "ImageCopies1"


    Set CopyImage1 = FoundCell.offfset(0, 464)
    
     CopyImage1.CopyPicture xlScreen, xlPicture
     
'Assign the "ImageCopies1" sheet to an object variable
Set wsImageCopies1 = ActiveWorkbook.Worksheets("ImageCopies1")


    Worksheets("ImageCopies1").Paste _
    Destination:=Worksheets("ImageCopies1").Range("B2")
    With Selection.ShapeRange
    .LockAspectRatio = msoFalse
   ' .Left = 10
    '.Top = 10
   .Width = 160
    .Height = 128
End With
MultiPage1.Pages.Add
Dim lblCaption1 As MSForms.Label
            On Error GoTo Err_Clr
            Set lblCaption1 = MultiPage1.Pages(7).Controls.Add("Forms.label.1", "myLabelCaption")
        With lblCaption1
        .Font.Name = "Arial Black"
        .Font.Size = 14
        .TextAlign = fmTextAlignCenter
        .Width = s
        .Height = h
        .Left = l
        .Top = t + s
        .ForeColor = vbWhite
        .BackColor = &H800000
        .WordWrap = False
        .AutoSize = False
        .Enabled = True
        .Caption = FoundCell.Offset(0, 484).Value
        Me.Repaint
        End With
        
        
  'Add and set the properties for an image control on the second page of the multipage control
Set oImage = Me.MultiPage1.Pages(7).Controls.Add("Forms.Image.1")
With oImage
    .Name = "image1"
    .Left = l
    .Top = t
    .Width = s
    .Height = s
    Sheets("ImageCopies1").Activate
      ThisWorkBook.Worksheets("ImageCopies1").ChartObjects(1).Chart.CopyPicture xlScreen, xlPicture, xlScreen
      


    Set MultiPage1.Pages(7).image1.Picture = PastePicture
    .PictureSizeMode = fmPictureSizeModeStretch
    End With
Else: Exit Sub
            End If
        End If
    End If
Err_Clr:
If Err <> 0 Then
Err.Clear
Resume Next
     End If


    End With
    End If


End Sub


Public Function ClearClipboard()
    OpenClipboard (0&)
    EmptyClipboard
    CloseClipboard
End Function
 
Upvote 0
Tried with different options still it retrieves the image 2 cells above from the specified row (FoundCell). Tried different options and no success.
Please help
code
Code: 
Private Sub btnSearch_Click()Call ClearClipboard
            Me.btnSearch.Visible = True
            Me.CBSearchCatagory.Visible = True
            Me.CBSearchResult.Visible = True
            Me.cmdUpdate.Visible = True
            Me.cmdAdd.Visible = True
Dim FoundCell As Range
Dim MoveToTwoRowsDown As Range


    If Me.CBSearchResult.Value = "" Then
        Me.tbCVCNo.Enabled = True
    With Me.CBSearchResult
        End With
            If Me.CBSearchCatagory.Value = "Search by CVC Number" Or _
                Me.CBSearchCatagory.Value = "Search by Nasico UID Number" Or _
                Me.CBSearchCatagory.Value = "Search by Tag Number" Or _
                Me.CBSearchCatagory.Value = "Search by Customer" Or _
                Me.CBSearchCatagory.Value = "Search by Valve Manufacturer" Or _
                Me.CBSearchCatagory.Value = "Search by Job Number" And _
                Me.CBSearchResult = "" Then Exit Sub
                Me.CBSearchResult.Visible = True
            End If
                If Me.CBSearchResult.ListIndex = 0 Then
                        Beep
                            Exit Sub
                End If
            If Me.CBSearchCatagory.Value = "Search by CVC Number" And Me.tbCVCNo.Value = Me.CBSearchResult Then
                With CBSearchResult
                 Application.ScreenUpdating = False
                        Set FoundCell = Cells.Find(what:=Me.CBSearchResult.Value, _
                                                            After:=Cells(1), _
                                                            LookIn:=xlValues, _
                                                            lookat:=xlWhole, _
                                                            SearchOrder:=xlByRows, _
                                                            SearchDirection:=xlPrevious, _
                                                            MatchCase:=False)
        If Not FoundCell Is Nothing Then
     '   Set MoveToTwoRowsDown = FoundCell.Offset(2, 0)
            Beep
Me.tbUIDNO.Value = FoundCell.Offset(0, 1).Value
Me.tbTAGNO.Value = FoundCell.Offset(0, 2).Value
'.....
'......
'.........
Me.TextBox333.Value = FoundCell.Offset(0, 455)
Me.ComboBox21.Value = FoundCell.Offset(0, 456)
Me.VSDJOBNO.Value = FoundCell.Offset(0, 457)


If FoundCell.Offset(0, 458).Value = "Dammam" Then Me.CBLOCATION.Value = "D"
If FoundCell.Offset(0, 458).Value = "Jubail" Then Me.CBLOCATION.Value = "J"


Me.timestamp.Caption = FoundCell.Offset(0, 459) = Format(timestamp.Caption, "mmmm dd yyyy hh:mm")
Me.TextBox295.Value = FoundCell.Offset(0, 460)
Me.TextBox302.Value = FoundCell.Offset(0, 461)


If FoundCell.Offset(0, 462).Value = "AFO" Then Me.OptionButton70.Value = True
If FoundCell.Offset(0, 462).Value = "AFC" Then Me.OptionButton71.Value = True
If FoundCell.Offset(0, 463).Value = "AFO" Then Me.OptionButton72.Value = True
If FoundCell.Offset(0, 463).Value = "AFC" Then Me.OptionButton73.Value = True
  
  
  Call ClearClipboard
           'Picture1-Comment Copy to userform
'Picture1-Label Copy to userform
Dim wsImageCopies1, wsinit1 As Worksheet
Dim oImage As image
Dim oShape, CopyImage1, PasteImage1 As shape
Dim oChart As Chart
Dim sTempFilename1, strInitDir1 As String
Dim s As Double
Dim l As Double
Dim t As Double
Dim h As Double




'Assign a filename for the temporary image
sTempFilename1 = Environ("temp") & "\temp_" & Format(Now, "yy-mm-dd_hh-mm-ss") & ".jpg"


'Dim s, l, t, h As Long
s = 260
t = 100
l = 24
h = 24
If FoundCell.Offset(0, 484).Text > 0 Then
Set wsinit1 = ActiveSheet
strInitDir1 = CurDir   'Optional: Save directory so can return to it.


MultiPage1.Pages.Add
Dim lblCaption1 As MSForms.Label
            On Error GoTo Err_Clr
            Set lblCaption1 = MultiPage1.Pages(7).Controls.Add("Forms.label.1", "myLabelCaption")
        With lblCaption1
        .Font.Name = "Arial Black"
        .Font.Size = 14
        .TextAlign = fmTextAlignCenter
        .Width = s
        .Height = h
        .Left = l
        .Top = t + s
        .ForeColor = vbWhite
        .BackColor = &H800000
        .WordWrap = False
        .AutoSize = False
        .Enabled = True
        .Caption = FoundCell.Offset(0, 484).Value
        Me.Repaint
        End With


  'Add and set the properties for an image control on the second page of the multipage control
Set oImage = Me.MultiPage1.Pages(7).Controls.Add("Forms.Image.1")
With oImage
    .Name = "image1"
    .Left = l
    .Top = t
    .Width = s
    .Height = s
    'Sheets("ImageCopies1").Activate
    '  ThisWorkBook.Worksheets("ImageCopies1").ChartObjects(1).Chart.CopyPicture xlScreen, xlPicture, xlScreen
      
   ' Dim sel As Range
    'Set sel = .Offset(FoundCell(2, 0))
   
'Range("C5").Offset(1, 2)


'Range(MoveToTwoRowsDown).Select
'Set MoveToTwoRowsDown = Selection.Offset(0, 464).Resize(Selection.Rows.Count + 2, _
   Selection.Columns.Count).Select
   
   
'Selection(MoveToTwoRowsDown) = FoundCell.Offset(0, "QW").Resize(Rows.Count + 2, Columns.Count + 0).Select
       
       
      'Set CopyImage1 = Worksheets("Data").Cells(FoundCell.Offset(2, 464).Resize(Rows.Count + 2, Columns.Count), 464)
      
      ' Set CopyImage1 = Worksheets("Data").Cells(FoundCell.Offset(0, "QW").Resize(FoundCell.Offset(FoundCell.Rows.Count + 2, FoundCell.Columns.Count).Select), "QW")
      
       'ActiveCell.Offset(0, 464).Select
       
       
        'Sheets("Data").Activate






'Below code works but copies 2 cells above the foumdcell row
'because I am having 2 rows of table headings
'Any advice,,,,xxxxxxxxxxxxxxx


'xxxxxxxxxxxxxxxxxxxx


'xxxxxxxxxxxxxxx


Set CopyImage1 = Worksheets("Data").Cells(FoundCell.Offset, "QW")


     CopyImage1.CopyPicture xlScreen, xlPicture


    Set MultiPage1.Pages(7).image1.Picture = PastePicture
    .PictureSizeMode = fmPictureSizeModeStretch
    
    End With
Else: Exit Sub
Call ClearClipboard
            End If
        End If
    'End If
Err_Clr:
If Err <> 0 Then
Err.Clear
Resume Next
     End If


    End With
    End If


End Sub
'------
Public Function ClearClipboard()
    OpenClipboard (0&)
    EmptyClipboard
    CloseClipboard
End Function
 
Upvote 0
SOLVED Re: Reference to variable Cell Image to Other sheet

YOU ARE GENIUS!!!
Problem Solved
Thanks..
 
Last edited:
Upvote 0
You must log in or register to reply here.

Similar threads

P
  • Question
VBA issue. runtime 91 - only occurring after change to Range?
Replies
6
Views
201
PTEOMARK
P
C
  • Solved
VBA Print to PDF Macro (with specific file name and type)
Replies
2
Views
288
CHOPDOG
C
C
  • Question
Problem using FIND method with a variable to update changes to a sheet cell
2
Replies
19
Views
609
6StringJazzer
6StringJazzer
gheyman
  • Solved
VBA to open another workbook and copy data - record the location of other workbook
Replies
5
Views
671
kevin9999
K
A
  • Question
VBA to Split Data From an Existing Table into Another Single Worksheet with Header for Each Section
Replies
1
Views
185
John_w
J

Forum statistics

Threads
1,214,979
Messages
6,122,557
Members
449,088
Latest member
davidcom

Share this page

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