Nhờ viết code VBA tự động hiện Shapes khi nhập số thứ tự

[thuytrangbp28]

Chào các bạn !
Mình có file Excel gồm 2 sheet. Sheet1 có bảng gồm 2 cột: số thứ tự và hình dạng tương ứng với các số thứ tự đó. Sheet2 có bảng trống gồm 2 cột giống Sheet1, giờ mình muốn khi nhập số thứ tự bất kỳ nào đó trong bảng ở Sheet2 thì sẽ hiện hình dạng tương ứng ở cột bên cạnh. Nhờ các bạn giúp mình viết Code VBA để thực hiện được công việc đó
Cảm ơn các bạn !

​

 

[HieuCD]

Chào các bạn !
Mình có file Excel gồm 2 sheet. Sheet1 có bảng gồm 2 cột: số thứ tự và hình dạng tương ứng với các số thứ tự đó. Sheet2 có bảng trống gồm 2 cột giống Sheet1, giờ mình muốn khi nhập số thứ tự bất kỳ nào đó trong bảng ở Sheet2 thì sẽ hiện hình dạng tương ứng ở cột bên cạnh. Nhờ các bạn giúp mình viết Code VBA để thực hiện được công việc đó
Cảm ơn các bạn !

View attachment 295899
View attachment 295902​

Dùng tạm code

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
  Dim rng As Range, shp, t
 
  If Target.Column = 1 Then
    Call DeleteShape(shp)
    If Target.Count = 1 Then
      If Target.Value <> Empty Then
        t = Target.Value
        For Each shp In Sheet1.Shapes
          If shp.Name = "Group " & t Then
            Sheet1.Range("B" & t + 1).Copy
            Target.Offset(, 1).Select
            ActiveSheet.Paste
          End If
        Next shp
      End If
    End If
    Target.Offset(1).Select
  End If
End Sub

Sub DeleteShape(shp)
  Dim t&, eRow&, i&
  eRow = Range("A" & Rows.Count).End(xlUp).Row
  For Each shp In Sheet2.Shapes 'Sheet.
    t = Mid(shp.Name, 7)
    For i = 2 To eRow
      If Range("A" & i).Value = t Then Exit For
    Next i
    If i > eRow Then shp.Delete
  Next shp
End Sub

Có vài trường hợp không xử lý được

 

[HUONGHCKT]

Chào các bạn !
Mình có file Excel gồm 2 sheet. Sheet1 có bảng gồm 2 cột: số thứ tự và hình dạng tương ứng với các số thứ tự đó. Sheet2 có bảng trống gồm 2 cột giống Sheet1, giờ mình muốn khi nhập số thứ tự bất kỳ nào đó trong bảng ở Sheet2 thì sẽ hiện hình dạng tương ứng ở cột bên cạnh. Nhờ các bạn giúp mình viết Code VBA để thực hiện được công việc đó
Cảm ơn các bạn !

View attachment 295899
View attachment 295902​

Thử xem.
xem file đính kèm
Đăng xong rồi mới thấy bài của Anh Hiếu.

 

[Maika8008]

Chào các bạn !
Mình có file Excel gồm 2 sheet. Sheet1 có bảng gồm 2 cột: số thứ tự và hình dạng tương ứng với các số thứ tự đó. Sheet2 có bảng trống gồm 2 cột giống Sheet1, giờ mình muốn khi nhập số thứ tự bất kỳ nào đó trong bảng ở Sheet2 thì sẽ hiện hình dạng tương ứng ở cột bên cạnh. Nhờ các bạn giúp mình viết Code VBA để thực hiện được công việc đó
Cảm ơn các bạn !

​

Tham khảo cách của tôi/
Chép tất cả code sau vào trang mã VBA của Sheet2

Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Column = 1 And Target.Row > 1 And Target.Count = 1 Then
        InsertShape Target.Value, Target.Row
        Application.EnableEvents = False
        Target.Offset(1).Activate
        Application.EnableEvents = True
    End If
End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    If Target.Column = 1 And Target.Row > 1 And Target.Count = 1 Then
        Dim oShd As Shape
        On Error Resume Next
        Set oShd = ActiveSheet.Shapes("Group " & Target.Value)
        If Not oShd Is Nothing Then oShd.Delete
    End If
End Sub

Sub InsertShape(ByVal iGrp As Long, ByVal iRow As Long)
    Dim oSh As Shape
    Application.ScreenUpdating = False
    'Chép và dán Group tù sheet1 vào sheet2
    Set oSh = Sheet1.Shapes("Group " & iGrp)
    oSh.Copy: Range("B" & iRow).Select: ActiveSheet.Paste
    'Can vi trí cua Group
    Set oSh = Sheet2.Shapes("Group " & iGrp)
    oSh.IncrementLeft 10.5: oSh.IncrementTop 5.25
    Application.ScreenUpdating = True
End Sub

 

[bebo021999]

Góp vui
đặt trong sheet2 module

Private Sub Worksheet_Change(ByVal Target As Range)
Dim ce As Range
If Intersect(Target, Range("A2:A1000")) Is Nothing Then Exit Sub
For Each ce In Target
   Call shapeInfo(ce.Offset(, 1))
   Set f = Sheets("sheet1").Range("A2:A10000").Find(ce)
   If f Is Nothing Then Exit Sub
   f.Offset(, 1).Copy ce.Offset(, 1)
Next
End Sub
Sub shapeInfo(ce As Range)
Dim shp As Shape
For Each shp In ActiveSheet.Shapes
    If shp.TopLeftCell.Address = ce.Address Then
        shp.Delete
        Exit Sub
    End If
Next
End Sub

 

[thuytrangbp28]

XIn lỗi các bạn vì hôm nay mới quay lại Topic vì có công việc riêng
Xin cảm ơn tất cả các bạn đã nhiệt tình giúp đỡ, code các bạn viết chạy rất tốt
Cảm ơn các bạn nhiều lắm !