Thêm 1 dạng PicForm (1 người xem)

anhtuan1066 · 1/9/07

Tôi thấy lúc trước trên diển đàn có tác giả làm PicForm dựa vào Comment... Và đây lại là dạng khác của PicForm, mời các bạn tham khảo
ANH TUẤN

anhtuan1066 · 12/12/08

Khi xưa ta bé ta ngu...
Ngày trước download file này ở các trang nước ngoài về, chỉ đơn giản thấy hay thì đưa lên... giờ xem lại code thấy.. buồn cười (code dài dòng, lúc chạy thì cà giật) ===> đâu cứ code nước ngoài viết là hay
He... he...
Sửa lại đây

PHP:

Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
  Dim mySel As Range
  On Error Resume Next
  If Not Intersect(Range("KeyCells"), Target) Is Nothing Then
    Set mySel = Selection
    ActiveSheet.Shapes(mySel.Address & "Final").Delete
    ActiveSheet.Shapes(mySel.Value).Copy
    With mySel
      .Offset(0, 2).PasteSpecial
      Selection.Name = .Address & "Final"
      Selection.Left = .Offset(0, 2).Left: Selection.Top = .Offset(0, 2).Top
      Selection.Width = .Offset(0, 2).Width: Selection.Height = .Offset(0, 2).Height
    End With
  End If
  mySel.Select
End Sub

File này dùng 3 hình mẫu có sẳn trong sheet, các bạn có thể cải tiến, thậm chí không cần mấy hình mẩu này tôi nghĩ cũng ko có vấn đề (nếu trong máy tính của ta đã có sẳn)
(Record quá trình Insert hình rồi chỉnh lại code)

anhtuan1066 · 14/12/08

Lại tiếp tục cải tiến:

PHP:

Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
  Dim PicRng As Range, Pos As String
  Application.ScreenUpdating = False
  On Error Resume Next
  If Not Intersect([B5:B8], Target) Is Nothing Then
    Set PicRng = Range("G1").CurrentRegion  '<--- Dat ten cho vung tra cuu hinh
    Pos = WorksheetFunction.VLookup(Target, PicRng, 2, 0) '<--- Xac dinh vi trí chua file hinh tren PC
    ActiveSheet.Shapes(Target.Address).Delete '<--- Xoa hinh da dat ten truoc do
    With ActiveSheet.Pictures.Insert(Pos)  '<--- Chen hinh moi
      .Name = Target.Address   '<--- Dat ten cho hinh moi chính là dia chi cell
      .Left = Target(1, 0).Left: .Top = Target(1, 0).Top '<--- Dinh vi cho hinh
      .Width = Target(1, 0).Width: .Height = Target(1, 0).Height '<--- Dinh chieu rong, cao cho hinh
    End With
  End If
  Application.ScreenUpdating = True
End Sub

Bỏ luôn mấy hình mẩu (lấy hình dựa vào đường dẩn)
Các bạn có thể dựa vào file này để làm PicForm (khá đơn giãn)

chiphoi3 · 29/9/09

Hàm của anh tuấn có thể insert thủ công được, tuy nhiên khi dùng chức năng fill down thì tất cả hình lại giống nhau, mặc dù đường dẫn của nó lại khác nhau

HOANG 1978 · 22/4/11

Tôi rât cảm ơn bài viết này đã giúp tôi giải quyết được vấn đề khó mà tôi đang vướng mắcNhưng trên file của tôi có nhiều hình lắm và tôi phải lấy hình từ một sheet khác.Một lần nữa cho tôi cám ơn bài viết này, cảm ơn bạn đã giúp tôi

tat thanh · 15/7/11

Anh Tuấn Ơ i ! Cho đứa Em Ngốc Nghếc này hỏi Anh thê m một chút nữa vêề đ oạn code chạy hình trong excel của Anh nhé ;(Set PicRng = Range("G1").CurrentRegion '<--- Dat ten cho vung tra cuu hinh) Anh dặt tê n cho vùng tra cứu hình là G1 vậy Anh vao dau de dat vay.them nua ( Pos = WorksheetFunction.VLookup(Target, PicRng, 2, 0) '<--- Xac dinh vi trí chua file hinh tren PC) day la duong dan den file hinh vay Em muon khai bao lai duong dan khac thi vao dau de khai vay Anh. Nho Anh chi dum Em voi nha . cam on Anh that nhieu

Hoàng Trọng Nghĩa · 15/7/11

tat thanh đã viết:
Anh Tuấn Ơ i ! Cho đứa Em Ngốc Nghếc này hỏi Anh thê m một chút nữa vêề đ oạn code chạy hình trong excel của Anh nhé ;(Set PicRng = Range("G1").CurrentRegion '<--- Dat ten cho vung tra cuu hinh) Anh dặt tê n cho vùng tra cứu hình là G1 vậy Anh vao dau de dat vay.

Dĩ nhiên dựa vào hình ảnh để đặt tên, máy không có tên này đâu nhé! Mục đích đặt tên này là để làm cái LookUp_Value, và dò tìm giá trị ở cột thứ 2 để chọn đường dẫn tới hình ảnh mà thôi.

tat thanh đã viết:
Them nua ( Pos = WorksheetFunction.VLookup(Target, PicRng, 2, 0) '<--- Xac dinh vi trí chua file hinh tren PC) day la duong dan den file hinh vay Em muon khai bao lai duong dan khac thi vao dau de khai vay Anh. Nho Anh chi dum Em voi nha . cam on Anh that nhieu

Muốn khai báo lại đường dẫn, bạn khai báo trong cột H, từ H1 trở đi.

Lưu ý: Khi hỏi bài hay post bài, bạn nên gõ dấu tiếng Việt cho rõ ràng bạn nhé!

techmodule · 25/12/11

Xin nhờ các bác, các anh các chị giúp đỡ, gấp gấp

Xin chào quý anh chị trên diễn đàn
Hiện tại em đang làm file báo giá tự động bằng excel (file đính kèm)
Em đã có tab data và tab list báo giá. Nhưng tab in báo giá thì thông số kĩ thuật và hình ảnh thì không hiện ra được?
Em cũng đọc qua Picform nhưng k hiểu lắm.
Vậy các anh chị ở đây có thể làm giúp em được không ạ.
XIn cảm ơn trước
http://dl.dropbox.com/u/2000670/Bang bao gia techmodule viet.xlsx

techmodule · 26/12/11

Hông có ai giúp em à

ali3340tc · 5/4/13

anhtuan1066 đã viết:

Lại tiếp tục cải tiến:

PHP:

Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
  Dim PicRng As Range, Pos As String
  Application.ScreenUpdating = False
  On Error Resume Next
  If Not Intersect([B5:B8], Target) Is Nothing Then
    Set PicRng = Range("G1").CurrentRegion  '<--- Dat ten cho vung tra cuu hinh
    Pos = WorksheetFunction.VLookup(Target, PicRng, 2, 0) '<--- Xac dinh vi trí chua file hinh tren PC
    ActiveSheet.Shapes(Target.Address).Delete '<--- Xoa hinh da dat ten truoc do
    With ActiveSheet.Pictures.Insert(Pos)  '<--- Chen hinh moi
      .Name = Target.Address   '<--- Dat ten cho hinh moi chính là dia chi cell
      .Left = Target(1, 0).Left: .Top = Target(1, 0).Top '<--- Dinh vi cho hinh
      .Width = Target(1, 0).Width: .Height = Target(1, 0).Height '<--- Dinh chieu rong, cao cho hinh
    End With
  End If
  Application.ScreenUpdating = True
End Sub

Bỏ luôn mấy hình mẩu (lấy hình dựa vào đường dẩn)
Các bạn có thể dựa vào file này để làm PicForm (khá đơn giãn)

Các bác pro cho hỏi: trong file của bác Tuấn thì cần phải có địa chỉ của ảnh thì mới Vlookup được. Nếu file ảnh và file excel cùng 1 folder và chuyển folder này từ địa chỉ này qua địa chỉ khác thì phải thay đổi địa chỉ file ở vùng vlookup. Làm thế nào để thay đổi địa chỉ mà không phải update lại địa chỉ?

ndu96081631 · 6/4/13

ali3340tc đã viết:
Các bác pro cho hỏi: trong file của bác Tuấn thì cần phải có địa chỉ của ảnh thì mới Vlookup được. Nếu file ảnh và file excel cùng 1 folder và chuyển folder này từ địa chỉ này qua địa chỉ khác thì phải thay đổi địa chỉ file ở vùng vlookup. Làm thế nào để thay đổi địa chỉ mà không phải update lại địa chỉ?

Thế thì tham khảo thử bài này xem:
http://www.giaiphapexcel.com/forum/showthread.php?51408-Chèn-hình-vào-cell-bằng-hàm-tự-tạo

ali3340tc · 6/4/13

ndu96081631 đã viết:
Thế thì tham khảo thử bài này xem:
http://www.giaiphapexcel.com/forum/showthread.php?51408-Ch%C3%A8n-h%C3%ACnh-v%C3%A0o-cell-b%E1%BA%B1ng-h%C3%A0m-t%E1%BB%B1-t%E1%BA%A1o

Cảm ơn thầy. Em đã làm được thành công.

M@trixs · 27/9/13

anhtuan1066 đã viết:
Khi xưa ta bé ta ngu...
Ngày trước download file này ở các trang nước ngoài về, chỉ đơn giản thấy hay thì đưa lên... giờ xem lại code thấy.. buồn cười (code dài dòng, lúc chạy thì cà giật) ===> đâu cứ code nước ngoài viết là hay
He... he...
Sửa lại đây

PHP:

Option Explicit Private Sub Worksheet_Change(ByVal Target As Range) Dim mySel As Range On Error Resume Next If Not Intersect(Range("KeyCells"), Target) Is Nothing Then Set mySel = Selection ActiveSheet.Shapes(mySel.Address & "Final").Delete ActiveSheet.Shapes(mySel.Value).Copy With mySel .Offset(0, 2).PasteSpecial Selection.Name = .Address & "Final" Selection.Left = .Offset(0, 2).Left: Selection.Top = .Offset(0, 2).Top Selection.Width = .Offset(0, 2).Width: Selection.Height = .Offset(0, 2).Height End With End If mySel.Select End Sub

File này dùng 3 hình mẫu có sẳn trong sheet, các bạn có thể cải tiến, thậm chí không cần mấy hình mẩu này tôi nghĩ cũng ko có vấn đề (nếu trong máy tính của ta đã có sẳn)
(Record quá trình Insert hình rồi chỉnh lại code)

Làm sao để thêm được hình khác theo bài này nữa vậy bạn @

anhtuan1066

anhtuan1066 · 27/9/13

M@trixs đã viết:
Làm sao để thêm được hình khác theo bài này nữa vậy bạn anhtuan1066

Bạn cho toàn bộ code này vào sheet nhé:

Mã:

Private Sub Worksheet_Change(ByVal Target As Range)
  Dim pic As Picture
  On Error Resume Next
  If Not Intersect(Range("B5:B10"), Target) Is Nothing Then
    If Target.Count = 1 Then
      With Target.Parent
        .Pictures(Target.Address).Delete
        Set pic = .Pictures(Target.Value)
      End With
      If Not pic Is Nothing Then
        pic.Copy
        Target.Offset(, 2).PasteSpecial
        With Selection
          .Name = Target.Address
          .ShapeRange.LockAspectRatio = msoFalse
          .Left = Target.Offset(, 2).Left: .Top = Target.Offset(, 2).Top
          .Width = Target.Offset(, 2).Width: .Height = Target.Offset(, 2).Height
        End With
      End If
    End If
  End If
  Target.Select
End Sub
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
  Dim rCel As Range, pic As Picture, arr(), n As Long
  On Error Resume Next
  If Not Intersect(Range("B5:B10"), Target) Is Nothing Then
    If Target.Count = 1 Then
      For Each pic In Target.Parent.Pictures
        If Not (pic.Name Like "$*$*") Then
          n = n + 1
          ReDim Preserve arr(1 To n)
          arr(n) = pic.Name
        End If
      Next
      If IsArray(arr) Then
        With Target.Validation
          .Delete
          .Add 3, , , Join(arr, ",")
        End With
      End If
    End If
  End If
End Sub

Khi bạn thêm bất cứ hình nào vào bảng tính thì validation cũng cập nhật
(Vùng chọn Validation là B5:B10)

M@trixs · 27/9/13

anhtuan1066 đã viết:
Bạn cho toàn bộ code này vào sheet nhé

Thay cho toàn bộ code cũ hả bạn ???

Ngoai Thanh · 27/9/13

anhtuan1066 đã viết:

Lại tiếp tục cải tiến:

PHP:

Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
  Dim PicRng As Range, Pos As String
  Application.ScreenUpdating = False
  On Error Resume Next
  If Not Intersect([B5:B8], Target) Is Nothing Then
    Set PicRng = Range("G1").CurrentRegion  '<--- Dat ten cho vung tra cuu hinh
    Pos = WorksheetFunction.VLookup(Target, PicRng, 2, 0) '<--- Xac dinh vi trí chua file hinh tren PC
    ActiveSheet.Shapes(Target.Address).Delete '<--- Xoa hinh da dat ten truoc do
    With ActiveSheet.Pictures.Insert(Pos)  '<--- Chen hinh moi
      .Name = Target.Address   '<--- Dat ten cho hinh moi chính là dia chi cell
      .Left = Target(1, 0).Left: .Top = Target(1, 0).Top '<--- Dinh vi cho hinh
      .Width = Target(1, 0).Width: .Height = Target(1, 0).Height '<--- Dinh chieu rong, cao cho hinh
    End With
  End If
  Application.ScreenUpdating = True
End Sub

Bỏ luôn mấy hình mẩu (lấy hình dựa vào đường dẩn)
Các bạn có thể dựa vào file này để làm PicForm (khá đơn giãn)

Cám ơn thày Anh tuấn ! thày cho hỏi liệu có thể phóng to ảnh lên vài lần khi rê chuột đến được không ? vì như thế dữ liệu dòng và cột chỉ cần nhỏ thôi . Khi cần xem ảnh ta rê chuột vào ảnh được phóng to để cho dễ nhìn .

ndu96081631 · 28/9/13

Ngoai Thanh đã viết:
Cám ơn thày Anh tuấn ! thày cho hỏi liệu có thể phóng to ảnh lên vài lần khi rê chuột đến được không ? vì như thế dữ liệu dòng và cột chỉ cần nhỏ thôi . Khi cần xem ảnh ta rê chuột vào ảnh được phóng to để cho dễ nhìn .

Rê chuột vào để phóng to thì khó. Ta có thể thay bằng: Click chuột vào ảnh để phóng to <--- Cái này quá dễ, record macro quá trình thay đổi size hình để có code

M@trixs đã viết:
Thay cho toàn bộ code cũ hả bạn ???

Chính xác là thế! Nếu không, chẳng lẽ có 2 code sự kiện Change trong cùng 1 sheet sao? Nó báo lỗi liền

Ngoai Thanh · 28/9/13

ndu96081631 đã viết:
Rê chuột vào để phóng to thì khó. Ta có thể thay bằng: Click chuột vào ảnh để phóng to <--- Cái này quá dễ, record macro quá trình thay đổi size hình để có code

Có lẽ nhà em hỏi chưa chuẩn thì đúng hơn, không phải "Rê chuột" đến , mà là "di chuyển chuột đến" thì hình tự động phóng to, khi chuột di chuyển đến ô khác thì nó trở lại trạng thái cũ . Điều nữa là thày có thể kết hợp lấy hyferlink ảnh tự động luôn thì tốt quá vì hyferlink thủ công , nếu nhiều ảnh thì cũng khá vất. Xin cám ơn thày .

ndu96081631 · 28/9/13

Ngoai Thanh đã viết:
Có lẽ nhà em hỏi chưa chuẩn thì đúng hơn, không phải "Rê chuột" đến , mà là "di chuyển chuột đến" thì hình tự động phóng to, khi chuột di chuyển đến ô khác thì nó trở lại trạng thái cũ

Rê chuột đến hay di chuyển chuột đến thì cũng như nhau thôi. Tóm lại: Picture không có sự kiện này
Ta chỉ có thể điều khiển hình phóng to, thu nhỏ khi ta dùng chuột CLICK VÀO HÌNH thôi

Ngoai Thanh đã viết:
Điều nữa là thày có thể kết hợp lấy hyferlink ảnh tự động luôn thì tốt quá vì hyferlink thủ công , nếu nhiều ảnh thì cũng khá vất. Xin cám ơn thày .

Hyperlink ảnh tự động nghĩa là sao?
Hyperlink theo tôi hiểu nghĩa là CLICK VÀO NÓ SẼ DI CHUYỂN ĐẾN NƠI KHÁC (đến bảng tính khác, đến file khác hoặc 1 trang web)
Vậy nên bạn nói Hyperlink ảnh tự động tôi cũng chẳng hiểu công việc ấy là gì nữa
Hay bạn muốn rằng: Khi chọn Validation thì ảnh tự động insert mà không cần phải insert trước đó? Nếu là vậy thì đây là bài toán khác hoàn toàn. Đã có trên GPE rồi đấy thôi:
http://www.giaiphapexcel.com/forum/showthread.php?51408-Chèn-hình-vào-cell-bằng-hàm-tự-tạo

Ngoai Thanh · 28/9/13

ndu96081631 đã viết:
Rê chuột đến hay di chuyển chuột đến thì cũng như nhau thôi. Tóm lại: Picture không có sự kiện này
Ta chỉ có thể điều khiển hình phóng to, thu nhỏ khi ta dùng chuột CLICK VÀO HÌNH thôi
***
Xin lỗi thày, vì link của ảnh mầu xanh nên nhà em tưởng phải Hyperlink đến file ảnh . Nói để diến đạt chính xác thật khó, nhà em đính kèm tập tin nhờ thày giúp . code phóng to, thu nhỏ nhà em làm rồi, nó hoạt động tốt, nhưng nhà em loay hoay mãi để nó tự động thực hiện khi di chuyển chuột đến các ô có chứa địa chỉ ảnh mà không được. Mong thày xem giúp vì nhà em trình độ VBA kiểu ăn đong nên khó quá . Không phải ta cần sự kiện của ảnh mà là của cell thày ạ, tức là sự kiện để chạy 2 sub trên,làm sao để đia chỉ trong code thay đổi theo chuột là được . Không biết ý tưởng của nhà em thế có được không nữa ? Nghe có vẻ kỳ kỳ , mong thay xem giúp và hồi âm . Biết thày không thích gọi là "Thày", nhưng 1 ngày là thày mà 1 chữ cũng là thày mà . Vả lại học thày bao nhiêu là chữ .

Thêm 1 dạng PicForm (1 người xem)

Người dùng đang xem chủ đề này

Thành viên gạo cội

File đính kèm

Thành viên gạo cội

File đính kèm

Thành viên gạo cội

File đính kèm

Thành viên mới

Thành viên mới

Thành viên mới

Chuyên gia GPE

Thành viên mới

Thành viên mới

Thành viên chính thức

Huyền thoại GPE

Thành viên chính thức

Thành viên thường trực

Thành viên gạo cội

Thành viên thường trực

Cánh Diều xanh

Huyền thoại GPE

Cánh Diều xanh

Huyền thoại GPE

Cánh Diều xanh

File đính kèm

Đếm ngược thời gian