Giúp hoàn thiện Thống kê biển báo hiều (1 người xem)

[Trần Văn Bình]

Hiện nay tôi đã chèn ảnh vào sheets_data tại cột chi tiết là thống kê tên quốc lộ, lý trình, mã biển
Khi nhập mã biển tại cột G & cột H thì cột I và cột J nhảy ra hình
theo code sau

Private Sub worksheet_change(ByVal target As Range)
If target.Cells.Count > 1 Then Exit Sub
If target = "" Then Exit Sub
If Not Intersect(Range("G10:H2000"), target) Is Nothing Then
Set Rng = CH_1.Range(CH_1.[b4], CH_1.[b2000].End(xlUp))
Set tim = Rng.Find(target, , , 1)
If tim Is Nothing Then
MsgBox "ma so nhap chua dung !", , "Chu y"
target.Select
Exit Sub
End If
'neu tim co:
'xoa bien bao cu:
On Error Resume Next
ActiveSheet.Shapes(target.Offset(0, 10).Value).Delete
'luu ma so moi
Application.EnableEvents = False
target.Offset(0, 10) = "Bien" & target.Value 'luu ma so de xoa anh cu neu nhap lai ma so khac
'copy hinh anh
tim.Offset(0, 1).Copy target.Offset(0, 2)
Application.EnableEvents = True
target.EntireRow.RowHeight = 30 'an dinh chieu cao dong
End If
End Sub

Nhưng trong trường hộp copy mã từ Sheets khác sang thì phải click chuột từng cell hình mới nhảy ra
vì vậy nhờ các anh chị giúp code khi nhấn nút Load anh khi đã có mã hình tại cột G và cột H thì hình tự động loát lên
Các phần liên quan cần giúp co file đính kèm

 

[Trần Văn Bình]

Nhờ các anh chị xem giúp cho

 

[ndu96081631]

Nhờ các anh chị xem giúp cho

Vì bạn copy hình từ sheet này sang sheet khác nên rắc rối 1 chút
Phải làm như sau:
- Đầu tiên phải đặt tên hình ở sheet Data_chitiet sao cho trùng với Tên file ảnh
- Copy là copy chính cái hình đã xác định qua tên chứ không phải copy cell
- Sau khi copy/paste sang sheet Chitiet, phải đặt lại tên hình trùng với địa chỉ của cell Target (mục đích để thông qua đó mà xóa hình cũ, thay hình mới)
- Phải dùng vòng lập để duyệt qua các cell Target ---> Lý do để code có thể chèn hình ngay cả khi bạn copy/paste nhiều cell vào cột G
Code như sau:

Private Sub worksheet_change(ByVal Target As Range)
  Dim Clls As Range, tRng As Range, fRng As Range, SrcRng As Range, pic As Picture
  On Error Resume Next
  If Not Intersect(Range("G10:H2000"), Target) Is Nothing Then
    Set tRng = Intersect(Range("G10:H2000"), Target)
    Set SrcRng = CH_1.Range(CH_1.[B4], CH_1.[B2000].End(xlUp))
    For Each Clls In tRng
      Set fRng = SrcRng.Find(Clls.Value, , , 1)
      If Not fRng Is Nothing Then
        Clls.Parent.Shapes(Clls.Address).Delete
        Set pic = CH_1.Pictures(fRng.Value)
        Clls.Offset(, 10) = "Bien" & Clls.Value
        pic.Copy: Clls.Parent.Paste
        With Selection
          .LockAspectRatio = False
          .Top = Clls.Top: .Left = Clls.Offset(, 1).Left
          .Width = Clls.Offset(, 1).Width: .Height = Clls.Height
          .Name = Clls.Address
        End With
        Clls.EntireRow.RowHeight = 30 'an dinh chieu cao dong
      End If
      Clls.Select
    Next
  End If
End Sub

Làm cho bạn tại sheet ChiTiet nhé... Phần còn lại bạn tự làm
Lưu ý: Nếu bạn dùng Excel 2003, hay xóa bỏ câu lệnh .LockAspectRatio = False nhé (ngược lại, nếu dùng Excel 2007 hoặc Excel 2010 bắt buộc phải có dòng lệnh này)

 

[Trần Văn Bình]

Vì bạn copy hình từ sheet này sang sheet khác nên rắc rối 1 chút
Phải làm như sau:
- Đầu tiên phải đặt tên hình ở sheet Data_chitiet sao cho trùng với Tên file ảnh
- Copy là copy chính cái hình đã xác định qua tên chứ không phải copy cell
- Sau khi copy/paste sang sheet Chitiet, phải đặt lại tên hình trùng với địa chỉ của cell Target (mục đích để thông qua đó mà xóa hình cũ, thay hình mới)
- Phải dùng vòng lập để duyệt qua các cell Target ---> Lý do để code có thể chèn hình ngay cả khi bạn copy/paste nhiều cell vào cột G
Code như sau:

Private Sub worksheet_change(ByVal Target As Range)
  Dim Clls As Range, tRng As Range, fRng As Range, SrcRng As Range, pic As Picture
  On Error Resume Next
  If Not Intersect(Range("G10:H2000"), Target) Is Nothing Then
    Set tRng = Intersect(Range("G10:H2000"), Target)
    Set SrcRng = CH_1.Range(CH_1.[B4], CH_1.[B2000].End(xlUp))
    For Each Clls In tRng
      Set fRng = SrcRng.Find(Clls.Value, , , 1)
      If Not fRng Is Nothing Then
        Clls.Parent.Shapes(Clls.Address).Delete
        Set pic = CH_1.Pictures(fRng.Value)
        Clls.Offset(, 10) = "Bien" & Clls.Value
        pic.Copy: Clls.Parent.Paste
        With Selection
          .LockAspectRatio = False
          .Top = Clls.Top: .Left = Clls.Offset(, 1).Left
          .Width = Clls.Offset(, 1).Width: .Height = Clls.Height
          .Name = Clls.Address
        End With
        Clls.EntireRow.RowHeight = 30 'an dinh chieu cao dong
      End If
      Clls.Select
    Next
  End If
End Sub

Làm cho bạn tại sheet ChiTiet nhé... Phần còn lại bạn tự làm
Lưu ý: Nếu bạn dùng Excel 2003, hay xóa bỏ câu lệnh .LockAspectRatio = False nhé (ngược lại, nếu dùng Excel 2007 hoặc Excel 2010 bắt buộc phải có dòng lệnh này)

Hiện mình đã chạy thử nhưng giữa mã biển và hình không khớp nhau nhờ bạn xem lại giúp mình nhé

 

[Trần Văn Bình]

Mình muốn lập nút Load hinh theo http://www.giaiphapexcel.com/forum/showthread.php?49595-File-excel-th%E1%BB%91ng-k%C3%AA-th%C3%A9p&p=312331#post312331

 

[Trần Văn Bình]

Mình muốn lập nút Load hinh theo http://www.giaiphapexcel.com/forum/showthread.php?49595-File-excel-th%E1%BB%91ng-k%C3%AA-th%C3%A9p&p=312331#post312331
View attachment 83733
Do mình không biết cách khai báo biển nó như thế nào
cho nên nhờ các bạn giúp cho

 

[Trần Văn Bình]

Nhờ các bác góp ý cho code này với nhé

Private Sub worksheet_change(ByVal Target As Range)    If Target.Cells.Count > 1 Then Exit Sub    If Target = "" Then Exit Sub        If Not Intersect(Range("G10:H2000"), Target) Is Nothing Then        Set Rng = CH_1.Range(CH_1.[B4], CH_1.[b1000].End(xlUp))        Set tim = Rng.Find(Target, , , 1)        If tim Is Nothing Then            MsgBox "ma so nhap chua dung !", , "Chu y"            Target.Select            Exit Sub        End If        'neu tim co:        'xoa bien bao cu:        On Error Resume Next        If Application.WorksheetFunction.IsNumber(Range("G10:H2000")) Then Application.SendKeys "{F2}{Enter}"        ActiveSheet.Shapes(Target.Offset(0, 10).Value).Delete        'luu ma so moi        Application.EnableEvents = False        Target.Offset(0, 10) = "Bien" & Target.Value 'luu ma so de xoa anh cu neu nhap lai ma so khac        'copy hinh anh        tim.Offset(0, 1).Copy Target.Offset(0, 2)        Application.EnableEvents = True        Target.EntireRow.RowHeight = 27 'an dinh chieu cao dong    End IfEnd Sub

If Application.WorksheetFunction.IsNumber(Range("G10:H2000")) Then Application.SendKeys "{F2}{Enter}" nên đưa thế nào cho phù hợp chư đưa đoạn này vào thì nó chạy tự động nhưng hơi chậm

 

[Trần Văn Bình]

Số lần Download nhiều mà sao không ai góp ý, thêm ý kiến, phản hồi giúp mình hoàn thiện