Nhờ giúp đỡ VBA - Chèn hình từ sheet này qua sheet khác

Liên hệ QC
Phamvanchat

Phamvanchat

Thành viên mới
Tham gia
10/10/18
Bài viết
36
Được thích
9
Dear các anh chị trong diễn đàn:

Em có 1 file bác các xuất từ phần mền ra: 2 file khác nhau - 1 file hình ảnh và 1 file nội dung:

Nay em tạo topic xin sự giúp đỡ của các anh chị trong diễn dàn để áp dụng VBA tăng tốc độ công việc

Yêu cầu em có để trong Sheet bác cáo theo file đính kèm ạ.

Trước em có nhờ anh @batman1 giúp đỡ ở topic cũ nhưng do vấn đề sửa đổi phần mền nên nó bị khác chút nên em lập topic này:

link topic cũ: https://www.giaiphapexcel.com/diend...sheet-này-sang-sheet-khác.152332/#post-995672


Mong sự giúp đỡ nhiệt tình từ các anh chị. Em xin chân thành cám ơn - Chúc anh chị trong diễn đàn thật nhiều sức khỏe và thành công!
 

File đính kèm

  • BCTT-Q12-T1.xls
    600.5 KB · Đọc: 15
Sắp xếp theo thời gian sắp xếp theo bầu chọn
Cấu trúc dữ liệu phải như bây giờ, dữ liệu trong 2 sheet bắt đầu từ dòng 1. Trong sheet BC các dòng cần chèn ảnh là các dòng có ở cột A rỗng và ở cột D có dữ liệu.

Thêm Module1 và dán code ở dưới. Lưu ý: chỉ có 1 dòng Option Explicit trong mỗi Module thôi nhé.
Mã: 
Option Explicit

Sub chen_anh()
Dim lastRow As Long, curr_row As Long, k As Long, r As Long, start As Long, msg As String, chiso(), shp As Shape, rng As Range, t
'    sheet HINH
    With ThisWorkbook.Worksheets("HINH")
        If .Shapes.Count = 0 Then Exit Sub  ' neu HINH khong co Anh thi ket thuc
        k = .Shapes.Count
'        mang chiso co 3 cot: cot 1 la noi dung cua cot D tren sheet, cot 2 la chi so dong cua Anh va noi dung, cot 3 la Ten Anh
        ReDim chiso(1 To .Shapes.Count, 1 To 3)
        For Each shp In .Shapes
            r = r + 1
            chiso(k + 1 - r, 1) = Application.Trim(Application.Clean(.Cells(r, "D").Value))
            chiso(k + 1 - r, 2) = k + 1 - r ' chi so dong
            chiso(k + 1 - r, 3) = shp.Name  ' ten Anh
        Next shp
    End With
    Application.ScreenUpdating = False
    start = 2
    With ThisWorkbook.Worksheets("BC")
        .Activate
        lastRow = .Cells(Rows.Count, "D").End(xlUp).Row + 1
        For r = 2 To lastRow
            If Len(.Range("A" & r).Value) > 30 Or r = lastRow Then  ' dong hien hanh la dong chua NGAY
                For k = r - 1 To start Step -1  ' duyet tung dong di tu dong cuoi cung len phia tren
                    If .Range("A" & k).Value = "" And .Range("D" & k).Value <> "" Then ' dong can chen Anh
                        Set rng = .Range("B" & k)   ' o ma o do se dan Anh
'                        xoa anh cu neu dang ton tai
                        On Error Resume Next
                        .Shapes(rng.Address).Delete
                        curr_row = 0
'                        tim noi dung hien hanh co o cot D cua sheet BC trong cot HINH!D
                        curr_row = Application.VLookup(Application.Trim(Application.Clean(.Range("D" & k).Value)), chiso, 2, 0)
                        On Error GoTo 0
                        If curr_row Then    ' neu tim thay noi dung hien hanh co o cot D cua sheet BC ...
'                            trong mang chiso thay gia tri vua tim duoc bang "x" de trong cac buoc sau khong tim o dong do nua
                            chiso(curr_row, 1) = "x"
'                            sao chep anh tu HINH vao bo nho
                            ThisWorkbook.Worksheets("HINH").Shapes(chiso(curr_row, 3)).Copy
                            rng.Select
'                            neu co loi "Paste method of Worksheet class failed" thi thu thay 0.4 bang gia tri lon hon, vd. 0.6
                            t = Timer
                            Do While Timer - t < 0.6
                                DoEvents
                            Loop
'                            dan anh tu bo nho vao o trong cot B cua sheet ngay hien hanh
                            .Paste
'                            dieu chinh kich thuoc anh va dat ten la dia chi cua o tai cot B
                            With Selection
                                .ShapeRange.LockAspectRatio = msoFalse
                                .Width = rng.Width
                                .Height = rng.Height
                                .Name = rng.Address ' dat ten cho Anh
                            End With
                        Else
                            msg = msg & "Gia tri tai D" & k & " trong sheet BC khong co trong sheet HINH" & vbCrLf
                        End If
                    End If
                Next k
                start = r + 1
            End If
        Next r
    End With
    Application.ScreenUpdating = True
    If Len(msg) Then
        MsgBox msg
    Else
        MsgBox "Da chen xong anh"
    End If
End Sub
 
Upvote 0
batman1 đã viết:
Cấu trúc dữ liệu phải như bây giờ, dữ liệu trong 2 sheet bắt đầu từ dòng 1. Trong sheet BC các dòng cần chèn ảnh là các dòng có ở cột A rỗng và ở cột D có dữ liệu.

Thêm Module1 và dán code ở dưới. Lưu ý: chỉ có 1 dòng Option Explicit trong mỗi Module thôi nhé.
Mã: 
Option Explicit

Sub chen_anh()
Dim lastRow As Long, curr_row As Long, k As Long, r As Long, start As Long, msg As String, chiso(), shp As Shape, rng As Range, t
'    sheet HINH
    With ThisWorkbook.Worksheets("HINH")
        If .Shapes.Count = 0 Then Exit Sub  ' neu HINH khong co Anh thi ket thuc
        k = .Shapes.Count
'        mang chiso co 3 cot: cot 1 la noi dung cua cot D tren sheet, cot 2 la chi so dong cua Anh va noi dung, cot 3 la Ten Anh
        ReDim chiso(1 To .Shapes.Count, 1 To 3)
        For Each shp In .Shapes
            r = r + 1
            chiso(k + 1 - r, 1) = Application.Trim(Application.Clean(.Cells(r, "D").Value))
            chiso(k + 1 - r, 2) = k + 1 - r ' chi so dong
            chiso(k + 1 - r, 3) = shp.Name  ' ten Anh
        Next shp
    End With
    Application.ScreenUpdating = False
    start = 2
    With ThisWorkbook.Worksheets("BC")
        .Activate
        lastRow = .Cells(Rows.Count, "D").End(xlUp).Row + 1
        For r = 2 To lastRow
            If Len(.Range("A" & r).Value) > 30 Or r = lastRow Then  ' dong hien hanh la dong chua NGAY
                For k = r - 1 To start Step -1  ' duyet tung dong di tu dong cuoi cung len phia tren
                    If .Range("A" & k).Value = "" And .Range("D" & k).Value <> "" Then ' dong can chen Anh
                        Set rng = .Range("B" & k)   ' o ma o do se dan Anh
'                        xoa anh cu neu dang ton tai
                        On Error Resume Next
                        .Shapes(rng.Address).Delete
                        curr_row = 0
'                        tim noi dung hien hanh co o cot D cua sheet BC trong cot HINH!D
                        curr_row = Application.VLookup(Application.Trim(Application.Clean(.Range("D" & k).Value)), chiso, 2, 0)
                        On Error GoTo 0
                        If curr_row Then    ' neu tim thay noi dung hien hanh co o cot D cua sheet BC ...
'                            trong mang chiso thay gia tri vua tim duoc bang "x" de trong cac buoc sau khong tim o dong do nua
                            chiso(curr_row, 1) = "x"
'                            sao chep anh tu HINH vao bo nho
                            ThisWorkbook.Worksheets("HINH").Shapes(chiso(curr_row, 3)).Copy
                            rng.Select
'                            neu co loi "Paste method of Worksheet class failed" thi thu thay 0.4 bang gia tri lon hon, vd. 0.6
                            t = Timer
                            Do While Timer - t < 0.6
                                DoEvents
                            Loop
'                            dan anh tu bo nho vao o trong cot B cua sheet ngay hien hanh
                            .Paste
'                            dieu chinh kich thuoc anh va dat ten la dia chi cua o tai cot B
                            With Selection
                                .ShapeRange.LockAspectRatio = msoFalse
                                .Width = rng.Width
                                .Height = rng.Height
                                .Name = rng.Address ' dat ten cho Anh
                            End With
                        Else
                            msg = msg & "Gia tri tai D" & k & " trong sheet BC khong co trong sheet HINH" & vbCrLf
                        End If
                    End If
                Next k
                start = r + 1
            End If
        Next r
    End With
    Application.ScreenUpdating = True
    If Len(msg) Then
        MsgBox msg
    Else
        MsgBox "Da chen xong anh"
    End If
End Sub
Nhấp chuột vào đây để mở rộng...
batman1 đã viết:
Cấu trúc dữ liệu phải như bây giờ, dữ liệu trong 2 sheet bắt đầu từ dòng 1. Trong sheet BC các dòng cần chèn ảnh là các dòng có ở cột A rỗng và ở cột D có dữ liệu.

Thêm Module1 và dán code ở dưới. Lưu ý: chỉ có 1 dòng Option Explicit trong mỗi Module thôi nhé.
Nhấp chuột vào đây để mở rộng...



batman1 đã viết:
Cấu trúc dữ liệu phải như bây giờ, dữ liệu trong 2 sheet bắt đầu từ dòng 1. Trong sheet BC các dòng cần chèn ảnh là các dòng có ở cột A rỗng và ở cột D có dữ liệu.

Thêm Module1 và dán code ở dưới. Lưu ý: chỉ có 1 dòng Option Explicit trong mỗi Module thôi nhé.
Mã: 
Option Explicit

Sub chen_anh()
Dim lastRow As Long, curr_row As Long, k As Long, r As Long, start As Long, msg As String, chiso(), shp As Shape, rng As Range, t
'    sheet HINH
    With ThisWorkbook.Worksheets("HINH")
        If .Shapes.Count = 0 Then Exit Sub  ' neu HINH khong co Anh thi ket thuc
        k = .Shapes.Count
'        mang chiso co 3 cot: cot 1 la noi dung cua cot D tren sheet, cot 2 la chi so dong cua Anh va noi dung, cot 3 la Ten Anh
        ReDim chiso(1 To .Shapes.Count, 1 To 3)
        For Each shp In .Shapes
            r = r + 1
            chiso(k + 1 - r, 1) = Application.Trim(Application.Clean(.Cells(r, "D").Value))
            chiso(k + 1 - r, 2) = k + 1 - r ' chi so dong
            chiso(k + 1 - r, 3) = shp.Name  ' ten Anh
        Next shp
    End With
    Application.ScreenUpdating = False
    start = 2
    With ThisWorkbook.Worksheets("BC")
        .Activate
        lastRow = .Cells(Rows.Count, "D").End(xlUp).Row + 1
        For r = 2 To lastRow
            If Len(.Range("A" & r).Value) > 30 Or r = lastRow Then  ' dong hien hanh la dong chua NGAY
                For k = r - 1 To start Step -1  ' duyet tung dong di tu dong cuoi cung len phia tren
                    If .Range("A" & k).Value = "" And .Range("D" & k).Value <> "" Then ' dong can chen Anh
                        Set rng = .Range("B" & k)   ' o ma o do se dan Anh
'                        xoa anh cu neu dang ton tai
                        On Error Resume Next
                        .Shapes(rng.Address).Delete
                        curr_row = 0
'                        tim noi dung hien hanh co o cot D cua sheet BC trong cot HINH!D
                        curr_row = Application.VLookup(Application.Trim(Application.Clean(.Range("D" & k).Value)), chiso, 2, 0)
                        On Error GoTo 0
                        If curr_row Then    ' neu tim thay noi dung hien hanh co o cot D cua sheet BC ...
'                            trong mang chiso thay gia tri vua tim duoc bang "x" de trong cac buoc sau khong tim o dong do nua
                            chiso(curr_row, 1) = "x"
'                            sao chep anh tu HINH vao bo nho
                            ThisWorkbook.Worksheets("HINH").Shapes(chiso(curr_row, 3)).Copy
                            rng.Select
'                            neu co loi "Paste method of Worksheet class failed" thi thu thay 0.4 bang gia tri lon hon, vd. 0.6
                            t = Timer
                            Do While Timer - t < 0.6
                                DoEvents
                            Loop
'                            dan anh tu bo nho vao o trong cot B cua sheet ngay hien hanh
                            .Paste
'                            dieu chinh kich thuoc anh va dat ten la dia chi cua o tai cot B
                            With Selection
                                .ShapeRange.LockAspectRatio = msoFalse
                                .Width = rng.Width
                                .Height = rng.Height
                                .Name = rng.Address ' dat ten cho Anh
                            End With
                        Else
                            msg = msg & "Gia tri tai D" & k & " trong sheet BC khong co trong sheet HINH" & vbCrLf
                        End If
                    End If
                Next k
                start = r + 1
            End If
        Next r
    End With
    Application.ScreenUpdating = True
    If Len(msg) Then
        MsgBox msg
    Else
        MsgBox "Da chen xong anh"
    End If
End Sub
Nhấp chuột vào đây để mở rộng...

Dạ. Cám ơn anh @batman1 rất nhiều, em đã chạy lần 1 và lần 2 thành công, nếu quá trình chạy phát sinh lỗi em lại làm phiền anh nữa nhé! Chúc anh sức khoẻ và thành công
 
Upvote 0
batman1 đã viết:
Cấu trúc dữ liệu phải như bây giờ, dữ liệu trong 2 sheet bắt đầu từ dòng 1. Trong sheet BC các dòng cần chèn ảnh là các dòng có ở cột A rỗng và ở cột D có dữ liệu.

Thêm Module1 và dán code ở dưới. Lưu ý: chỉ có 1 dòng Option Explicit trong mỗi Module thôi nhé.
Mã: 
Option Explicit

Sub chen_anh()
Dim lastRow As Long, curr_row As Long, k As Long, r As Long, start As Long, msg As String, chiso(), shp As Shape, rng As Range, t
'    sheet HINH
    With ThisWorkbook.Worksheets("HINH")
        If .Shapes.Count = 0 Then Exit Sub  ' neu HINH khong co Anh thi ket thuc
        k = .Shapes.Count
'        mang chiso co 3 cot: cot 1 la noi dung cua cot D tren sheet, cot 2 la chi so dong cua Anh va noi dung, cot 3 la Ten Anh
        ReDim chiso(1 To .Shapes.Count, 1 To 3)
        For Each shp In .Shapes
            r = r + 1
            chiso(k + 1 - r, 1) = Application.Trim(Application.Clean(.Cells(r, "D").Value))
            chiso(k + 1 - r, 2) = k + 1 - r ' chi so dong
            chiso(k + 1 - r, 3) = shp.Name  ' ten Anh
        Next shp
    End With
    Application.ScreenUpdating = False
    start = 2
    With ThisWorkbook.Worksheets("BC")
        .Activate
        lastRow = .Cells(Rows.Count, "D").End(xlUp).Row + 1
        For r = 2 To lastRow
            If Len(.Range("A" & r).Value) > 30 Or r = lastRow Then  ' dong hien hanh la dong chua NGAY
                For k = r - 1 To start Step -1  ' duyet tung dong di tu dong cuoi cung len phia tren
                    If .Range("A" & k).Value = "" And .Range("D" & k).Value <> "" Then ' dong can chen Anh
                        Set rng = .Range("B" & k)   ' o ma o do se dan Anh
'                        xoa anh cu neu dang ton tai
                        On Error Resume Next
                        .Shapes(rng.Address).Delete
                        curr_row = 0
'                        tim noi dung hien hanh co o cot D cua sheet BC trong cot HINH!D
                        curr_row = Application.VLookup(Application.Trim(Application.Clean(.Range("D" & k).Value)), chiso, 2, 0)
                        On Error GoTo 0
                        If curr_row Then    ' neu tim thay noi dung hien hanh co o cot D cua sheet BC ...
'                            trong mang chiso thay gia tri vua tim duoc bang "x" de trong cac buoc sau khong tim o dong do nua
                            chiso(curr_row, 1) = "x"
'                            sao chep anh tu HINH vao bo nho
                            ThisWorkbook.Worksheets("HINH").Shapes(chiso(curr_row, 3)).Copy
                            rng.Select
'                            neu co loi "Paste method of Worksheet class failed" thi thu thay 0.4 bang gia tri lon hon, vd. 0.6
                            t = Timer
                            Do While Timer - t < 0.6
                                DoEvents
                            Loop
'                            dan anh tu bo nho vao o trong cot B cua sheet ngay hien hanh
                            .Paste
'                            dieu chinh kich thuoc anh va dat ten la dia chi cua o tai cot B
                            With Selection
                                .ShapeRange.LockAspectRatio = msoFalse
                                .Width = rng.Width
                                .Height = rng.Height
                                .Name = rng.Address ' dat ten cho Anh
                            End With
                        Else
                            msg = msg & "Gia tri tai D" & k & " trong sheet BC khong co trong sheet HINH" & vbCrLf
                        End If
                    End If
                Next k
                start = r + 1
            End If
        Next r
    End With
    Application.ScreenUpdating = True
    If Len(msg) Then
        MsgBox msg
    Else
        MsgBox "Da chen xong anh"
    End If
End Sub
Nhấp chuột vào đây để mở rộng...

Hi anh @batman1. Em nhờ anh xem lại file này giúp với ạ, nó cũng như file tháng 1 nhưng sao máy ngầy đầu bị sai hình ạ. Em xin cám ơn. Mong anh phản hổi.
 

File đính kèm

  • BC-TT-T2.xlsm
    416 KB · Đọc: 10
Upvote 0
Phamvanchat đã viết:
Hi anh @batman1. Em nhờ anh xem lại file này giúp với ạ, nó cũng như file tháng 1 nhưng sao máy ngầy đầu bị sai hình ạ.
Nhấp chuột vào đây để mở rộng...
2 tập tin không như nhau.

Ở tập tin tháng 1 thì chỉ số trong các tên ảnh đi từ trên xuống trong sheet HINH là các số liên tiếp: 1, 2, ..., 83, và các ảnh Picture 1 - Picture 83 cũng nằm ở các ô liên tiếp trong cột B: Picture 1 - Picture 83 -> B1 - B83

Ở tập tin tháng 2: Picture 1 - Picture 38 nằm ở B1 - B38, Picture 63 nằm ở B39, Picture 39 - Picture 62 nằm ở B40 - B63.
Ngoài ra ở D34 có thêm "Text Box 1" với nội dung: "Tại điểm mở 2 đầu dpc chưa có trụ cam đen + trụ dẻo. Kiến nghị bổ sung 6 trụ dẻo + 2 trụ cam đen".

Tại sao máy tạo dữ liệu mà làm việc không chuẩn? Máy chứ có phải là người đâu mà nhầm lẫn.

Để khác phục các vấn đề trên thì thay
Mã: 
For Each shp In .Shapes
    r = r + 1
    chiso(k + 1 - r, 1) = Application.Trim(Application.Clean(.Cells(r, "D").Value))
    chiso(k + 1 - r, 2) = k + 1 - r ' chi so dong
    chiso(k + 1 - r, 3) = shp.Name  ' ten Anh
Next shp

bằng

Mã: 
For Each shp In .Shapes
    If LCase(shp.Name) Like "picture*" Then
        shp.Top = shp.Top + 3   ' nhieu anh chớm len cell o dong truoc nen dung shp.TopLeftCell.Row se sai. De khac phuc truoc tien ta dich Picture xuong duoi mot chut - 3 point
        r = shp.TopLeftCell.Row
        chiso(k + 1 - r, 1) = Application.Trim(Application.Clean(.Cells(r, "D").Value))
        chiso(k + 1 - r, 2) = k + 1 - r ' chi so dong
        chiso(k + 1 - r, 3) = shp.Name  ' ten Anh
        shp.Top = shp.Top - 3   ' dich len phia tren 3 point - tra lai vi tri cu cua Picture
    End If
Next shp
 
Upvote 0
Ngoài ra ở D34 có thêm "Text Box 1" với nội dung: "Tại điểm mở 2 đầu dpc chưa có trụ cam đen + trụ dẻo. Kiến nghị bổ sung 6 trụ dẻo + 2 trụ cam đen".
Nhấp chuột vào đây để mở rộng...
Cái này lỗi của em chứ không pahir phần mềm anh ạ.

Ở tập tin tháng 2: Picture 1 - Picture 38 nằm ở B1 - B38, Picture 63 nằm ở B39, Picture 39 - Picture 62 nằm ở B40 - B63.
Tại sao máy tạo dữ liệu mà làm việc không chuẩn? Máy chứ có phải là người đâu mà nhầm lẫn.
Nhấp chuột vào đây để mở rộng...

Đúng là máy xuất ra từ phần mềm và nhân viên họ nhập báo cáo lên, em cũng chỉ xuất y nguyên như vậy ạ, chỉ sau khi add hình xong mới kiểm tra sửa chữa chính tả thôi anh ạ.

For Each shp In .Shapes
If LCase(shp.Name) Like "picture*" Then
shp.Top = shp.Top + 3 ' nhieu anh chớm len cell o dong truoc nen dung shp.TopLeftCell.Row se sai. De khac phuc truoc tien ta dich Picture xuong duoi mot chut - 3 point
r = shp.TopLeftCell.Row
chiso(k + 1 - r, 1) = Application.Trim(Application.Clean(.Cells(r, "D").Value))
chiso(k + 1 - r, 2) = k + 1 - r ' chi so dong
chiso(k + 1 - r, 3) = shp.Name ' ten Anh
shp.Top = shp.Top - 3 ' dich len phia tren 3 point - tra lai vi tri cu cua Picture
End If
Next shp
Nhấp chuột vào đây để mở rộng...

Em thay mã này và kiểm tra cả 2 file đã thành công nhé anh! Em xin phép xóa topic cũ (để tiết kiệm tài nguyên cho diễn dần) và giữ topic này có gì các bạn cần vào tham khỏa cho tiện ạ.


Chân thành cám ơn anh!
 
Upvote 0
- Em có chạy thêm file có 264 hình thì nó báo lỗi như hình đính kèm! Nhờ anh @batman1 xem giúp em bị lỗi gì với ạ, Em chân thành cám ơn.

- Với lại em muốn hình vào ô B có kích thước cố định là * (rộng = 21 và cao = 108) * có được hay không ạ, vì khi xuất ra nó tự động dãn theo chữ, em phải chọn thủ công các ô cần chèn hình vào hơi mất thời gian.
 

File đính kèm

  • z2436331261341_65480360feb74d3026f99795a03305d3.jpg
    z2436331261341_65480360feb74d3026f99795a03305d3.jpg
    71.1 KB · Đọc: 6
  • BCTT-HM_T3.xlsm
    1.6 MB · Đọc: 6
Lần chỉnh sửa cuối:
Upvote 0
Phamvanchat đã viết:
- Em có chạy thêm file có 264 hình thì nó báo lỗi như hình đính kèm!
Nhấp chuột vào đây để mở rộng...
Tôi đếm thấy có 263 hình thôi. Tại B84 không có hình nào cả.

Liệu tình huống này có thể sảy ra không hay do lỗi bạn sơ ý xóa đi? Do B84 không có hình nên Picture 84-Picture 263 bị đẩy xuống B85-B264. Code khai báo mảng chiso có 263 dòng (số hình trên sheet) trong khi code truy cập tới dòng 0 (k+1-r = 263+1-264 = 0) của mảng chiso nên có lỗi. Nếu đó là lỗi do phần mềm thì hơi lạ, nhưng tôi có thể sửa code để khắc phục lỗi này của phần mềm.

Ngoài ra cũng lạ là ảnh Picture 263 bị dịch xuống nhiều trong ô. Phần mềm mà sao xuất dữ liệu vào sheet không nhất quán vậy?

- Với lại em muốn hình vào ô B có kích thước cố định là * (rộng = 21 và cao = 108) * có được hay không ạ, vì khi xuất ra nó tự động dãn theo chữ, em phải chọn thủ công các ô cần chèn hình vào hơi mất thời gian.
Nhấp chuột vào đây để mở rộng...
Tôi không hiểu đỏ đỏ. Hãy mô tả cụ thể hơn.
 
Upvote 0
Tôi đếm thấy có 263 hình thôi. Tại B84 không có hình nào cả.

Liệu tình huống này có thể sảy ra không hay do lỗi bạn sơ ý xóa đi? Do B84 không có hình nên Picture 84-Picture 263 bị đẩy xuống B85-B264. Code khai báo mảng chiso có 263 dòng (số hình trên sheet) trong khi code truy cập tới dòng 0 (k+1-r = 263+1-264 = 0) của mảng chiso nên có lỗi. Nếu đó là lỗi do phần mềm thì hơi lạ, nhưng tôi có thể sửa code để khắc phục lỗi này của phần mềm.

Ngoài ra cũng lạ là ảnh Picture 263 bị dịch xuống nhiều trong ô. Phần mềm mà sao xuất dữ liệu vào sheet không nhất quán vậy?
Nhấp chuột vào đây để mở rộng...

Dạ. Đôi khi nó xuất bị thiếu, em cũng chưa biết lý do nữa ạ, anh xem khắc phục giúp em nếu cái nào thiếu có thể để rỗng được không ạ


Tôi không hiểu đỏ đỏ. Hãy mô tả cụ thể hơn.
Nhấp chuột vào đây để mở rộng...

Khi xuất ra như hình em đính kèm, nó tự động dãn dòng như hình ạ, như thế nó xấu không được vuông vức như file báo cáo, em thường chọn column width=21 và row height = 108 để cho cân đối ạ. Nhueng toàn phải chọn thủ công bằng tay ạ. file mẫu em nhờ VBA là đã chọn các ô cần chèn hình và gõ chiều rộng, cao theo như trên ấy ạ
 

File đính kèm

  • z2436601240267_0c5a1463b4764d577219b6deb77e3517.jpg
    z2436601240267_0c5a1463b4764d577219b6deb77e3517.jpg
    148.4 KB · Đọc: 8
Upvote 0
Phamvanchat đã viết:
Dạ. Đôi khi nó xuất bị thiếu, em cũng chưa biết lý do nữa ạ, anh xem khắc phục giúp em nếu cái nào thiếu có thể để rỗng được không ạ
Nhấp chuột vào đây để mở rộng...
Tôi sửa cho bạn nhưng nếu là tôi thì tôi không tin vào hệ thống. Làm gì có chương trình nào lúc thì làm thế này, lúc làm khác. Lúc làm thừa cái này, lúc quên làm cái khác. Một chương trình như thế không thể tin cậy được.

Code ở dưới, bạn tự kiểm tra cho cả các trường hợp dữ liệu trước đó.

Lưu ý:
1. Code mới khác cũ ở chỗ
thay
Mã: 
k = .Shapes.Count
ReDim chiso(1 To .Shapes.Count, 1 To 3)
bằng
Mã: 
For Each shp In .Shapes
    If LCase(shp.Name) Like "picture*" Then
        shp.Top = shp.Top + 3
        If max_row < shp.TopLeftCell.Row Then max_row = shp.TopLeftCell.Row
        shp.Top = shp.Top - 3
    End If
Next shp
k = max_row
ThisWorkbook.Worksheets("BC").Columns("B:B").ColumnWidth = 21   ' Column With cua cot B = 21
'        mang chiso co 3 cot: cot 1 la noi dung cua cot D tren sheet, cot 2 la chi so dong cua Anh va noi dung, cot 3 la Ten Anh
ReDim chiso(1 To k, 1 To 3)

và trước

Mã: 
rng.Select

thì thêm

Mã: 
rng.EntireRow.RowHeight = 108   ' Row Height cua dong hien hanh bang 108

2. Code mới.
Mã: 
Option Explicit

Sub chen_anh()
Dim lastRow As Long, curr_row As Long, k As Long, r As Long, start As Long, msg As String, chiso(), shp As Shape, rng As Range, max_row As Long, t
'    sheet HINH
    With ThisWorkbook.Worksheets("HINH")
        If .Shapes.Count = 0 Then Exit Sub  ' neu HINH khong co Anh thi ket thuc
       
        For Each shp In .Shapes
            If LCase(shp.Name) Like "picture*" Then
                shp.Top = shp.Top + 3
                If max_row < shp.TopLeftCell.Row Then max_row = shp.TopLeftCell.Row
                shp.Top = shp.Top - 3
            End If
        Next shp
        k = max_row
        ThisWorkbook.Worksheets("BC").Columns("B:B").ColumnWidth = 21   ' Column With cua cot B = 21
        '        mang chiso co 3 cot: cot 1 la noi dung cua cot D tren sheet, cot 2 la chi so dong cua Anh va noi dung, cot 3 la Ten Anh
        ReDim chiso(1 To k, 1 To 3)
        For Each shp In .Shapes
            If LCase(shp.Name) Like "picture*" Then
                shp.Top = shp.Top + 3   ' nhieu anh cho´m len cell o dong truoc nen dung shp.TopLeftCell.Row se sai. De khac phuc truoc tien ta dich Picture xuong duoi mot chut - 3 point
                r = shp.TopLeftCell.Row
                chiso(k + 1 - r, 1) = Application.Trim(Application.Clean(.Cells(r, "D").Value))
                chiso(k + 1 - r, 2) = k + 1 - r ' chi so dong
                chiso(k + 1 - r, 3) = shp.Name  ' ten Anh
                shp.Top = shp.Top - 3   ' dich len phia tren 3 point - tra lai vi tri cu cua Picture
            End If
        Next shp
    End With
    Application.ScreenUpdating = False
    start = 2
    With ThisWorkbook.Worksheets("BC")
        .Activate
        lastRow = .Cells(Rows.Count, "D").End(xlUp).Row + 1
        For r = 2 To lastRow
            If Len(.Range("A" & r).Value) > 30 Or r = lastRow Then  ' dong hien hanh la dong chua NGAY
                For k = r - 1 To start Step -1  ' duyet tung dong di tu dong cuoi cung len phia tren
                    If .Range("A" & k).Value = "" And .Range("D" & k).Value <> "" Then ' dong can chen Anh
                        Set rng = .Range("B" & k)   ' o ma o do se dan Anh
'                        xoa anh cu neu dang ton tai
                        On Error Resume Next
                        .Shapes(rng.Address).Delete
                        curr_row = 0
'                        tim noi dung hien hanh co o cot D cua sheet BC trong cot HINH!D
                        curr_row = Application.VLookup(Application.Trim(Application.Clean(.Range("D" & k).Value)), chiso, 2, 0)
                        On Error GoTo 0
                        If curr_row Then    ' neu tim thay noi dung hien hanh co o cot D cua sheet BC ...
'                            trong mang chiso thay gia tri vua tim duoc bang "x" de trong cac buoc sau khong tim o dong do nua
                            chiso(curr_row, 1) = "x"
'                            sao chep anh tu HINH vao bo nho
                            ThisWorkbook.Worksheets("HINH").Shapes(chiso(curr_row, 3)).Copy
                           
                            rng.EntireRow.RowHeight = 108   ' Row Height cua dong hien hanh bang 108
                            rng.Select
'                            neu co loi "Paste method of Worksheet class failed" thi thu thay 0.4 bang gia tri lon hon, vd. 0.6
                            t = Timer
                            Do While Timer - t < 0.6
                                DoEvents
                            Loop
'                            dan anh tu bo nho vao o trong cot B cua sheet ngay hien hanh
                            .Paste
'                            dieu chinh kich thuoc anh va dat ten la dia chi cua o tai cot B
                            With Selection
                                .ShapeRange.LockAspectRatio = msoFalse
                                .Width = rng.Width
                                .Height = rng.Height
                                .Name = rng.Address ' dat ten cho Anh
                            End With
                        Else
                            msg = msg & "Gia tri tai D" & k & " trong sheet BC khong co trong sheet HINH, hoac Anh ung voi no khong co trong sheet HINH" & vbCrLf
                        End If
                    End If
                Next k
                start = r + 1
            End If
        Next r
    End With
    Application.ScreenUpdating = True
    If Len(msg) Then
        MsgBox msg
    Else
        MsgBox "Da chen xong anh"
    End If
End Sub
 
Upvote 0
batman1 đã viết:
Code ở dưới, bạn tự kiểm tra cho cả các trường hợp dữ liệu trước đó.

Lưu ý:
1. Code mới khác cũ ở chỗ
thay
Mã: 
k = .Shapes.Count
ReDim chiso(1 To .Shapes.Count, 1 To 3)
bằng
Mã: 
For Each shp In .Shapes
    If LCase(shp.Name) Like "picture*" Then
        shp.Top = shp.Top + 3
        If max_row < shp.TopLeftCell.Row Then max_row = shp.TopLeftCell.Row
        shp.Top = shp.Top - 3
    End If
Next shp
k = max_row
ThisWorkbook.Worksheets("BC").Columns("B:B").ColumnWidth = 21   ' Column With cua cot B = 21
'        mang chiso co 3 cot: cot 1 la noi dung cua cot D tren sheet, cot 2 la chi so dong cua Anh va noi dung, cot 3 la Ten Anh
ReDim chiso(1 To k, 1 To 3)

và trước

Mã: 
rng.Select

thì thêm

Mã: 
rng.EntireRow.RowHeight = 108   ' Row Height cua dong hien hanh bang 108

2. Code mới.
Mã: 
Option Explicit

Sub chen_anh()
Dim lastRow As Long, curr_row As Long, k As Long, r As Long, start As Long, msg As String, chiso(), shp As Shape, rng As Range, max_row As Long, t
'    sheet HINH
    With ThisWorkbook.Worksheets("HINH")
        If .Shapes.Count = 0 Then Exit Sub  ' neu HINH khong co Anh thi ket thuc
     
        For Each shp In .Shapes
            If LCase(shp.Name) Like "picture*" Then
                shp.Top = shp.Top + 3
                If max_row < shp.TopLeftCell.Row Then max_row = shp.TopLeftCell.Row
                shp.Top = shp.Top - 3
            End If
        Next shp
        k = max_row
        ThisWorkbook.Worksheets("BC").Columns("B:B").ColumnWidth = 21   ' Column With cua cot B = 21
        '        mang chiso co 3 cot: cot 1 la noi dung cua cot D tren sheet, cot 2 la chi so dong cua Anh va noi dung, cot 3 la Ten Anh
        ReDim chiso(1 To k, 1 To 3)
        For Each shp In .Shapes
            If LCase(shp.Name) Like "picture*" Then
                shp.Top = shp.Top + 3   ' nhieu anh cho´m len cell o dong truoc nen dung shp.TopLeftCell.Row se sai. De khac phuc truoc tien ta dich Picture xuong duoi mot chut - 3 point
                r = shp.TopLeftCell.Row
                chiso(k + 1 - r, 1) = Application.Trim(Application.Clean(.Cells(r, "D").Value))
                chiso(k + 1 - r, 2) = k + 1 - r ' chi so dong
                chiso(k + 1 - r, 3) = shp.Name  ' ten Anh
                shp.Top = shp.Top - 3   ' dich len phia tren 3 point - tra lai vi tri cu cua Picture
            End If
        Next shp
    End With
    Application.ScreenUpdating = False
    start = 2
    With ThisWorkbook.Worksheets("BC")
        .Activate
        lastRow = .Cells(Rows.Count, "D").End(xlUp).Row + 1
        For r = 2 To lastRow
            If Len(.Range("A" & r).Value) > 30 Or r = lastRow Then  ' dong hien hanh la dong chua NGAY
                For k = r - 1 To start Step -1  ' duyet tung dong di tu dong cuoi cung len phia tren
                    If .Range("A" & k).Value = "" And .Range("D" & k).Value <> "" Then ' dong can chen Anh
                        Set rng = .Range("B" & k)   ' o ma o do se dan Anh
'                        xoa anh cu neu dang ton tai
                        On Error Resume Next
                        .Shapes(rng.Address).Delete
                        curr_row = 0
'                        tim noi dung hien hanh co o cot D cua sheet BC trong cot HINH!D
                        curr_row = Application.VLookup(Application.Trim(Application.Clean(.Range("D" & k).Value)), chiso, 2, 0)
                        On Error GoTo 0
                        If curr_row Then    ' neu tim thay noi dung hien hanh co o cot D cua sheet BC ...
'                            trong mang chiso thay gia tri vua tim duoc bang "x" de trong cac buoc sau khong tim o dong do nua
                            chiso(curr_row, 1) = "x"
'                            sao chep anh tu HINH vao bo nho
                            ThisWorkbook.Worksheets("HINH").Shapes(chiso(curr_row, 3)).Copy
                         
                            rng.EntireRow.RowHeight = 108   ' Row Height cua dong hien hanh bang 108
                            rng.Select
'                            neu co loi "Paste method of Worksheet class failed" thi thu thay 0.4 bang gia tri lon hon, vd. 0.6
                            t = Timer
                            Do While Timer - t < 0.6
                                DoEvents
                            Loop
'                            dan anh tu bo nho vao o trong cot B cua sheet ngay hien hanh
                            .Paste
'                            dieu chinh kich thuoc anh va dat ten la dia chi cua o tai cot B
                            With Selection
                                .ShapeRange.LockAspectRatio = msoFalse
                                .Width = rng.Width
                                .Height = rng.Height
                                .Name = rng.Address ' dat ten cho Anh
                            End With
                        Else
                            msg = msg & "Gia tri tai D" & k & " trong sheet BC khong co trong sheet HINH, hoac Anh ung voi no khong co trong sheet HINH" & vbCrLf
                        End If
                    End If
                Next k
                start = r + 1
            End If
        Next r
    End With
    Application.ScreenUpdating = True
    If Len(msg) Then
        MsgBox msg
    Else
        MsgBox "Da chen xong anh"
    End If
End Sub
Nhấp chuột vào đây để mở rộng...

Dạ em cám ơn anh trước! để em test các trường hợp rồi trả lời sau anh nhé!

Đúng là cái phần mềm có vấn đề em có ý kiến nhiều lần nhưng cty vẫn không sửa đổi.
 
Lần chỉnh sửa cuối:
Upvote 0
Bạn phải đăng nhập hoặc đăng ký để trả lời bài viết tại đây.
Web KT

Bài viết mới nhất

T
Không đếm dữ liệu rỗng trong PivotTable
Trả lời
8
Đọc
1K
hoangtuaotrang_hp_vn
H
C
Chia sẻ: Kết quả xổ số Keno
    • Thích
    • Cười
Trả lời
7
Đọc
182
bebo021999
B
Tuấn Bụng Bự
  • Question
Tìm Bộ 8 số xuất hiện nhiều nhất trong random( 1 - 80)
2
Trả lời
25
Đọc
491
bebo021999
B
nguyenphuochien166
Cách Vlookup hoặc cách lấy thông tin dữ liệu có dấu mũ lũy thừa?
    • Cười
Trả lời
4
Đọc
60
Hoàng Tuấn 868
H
B
Lọc dữ liệu trùng, đếm số lần, tự tô màu theo điều kiện.
Trả lời
3
Đọc
96
batista911
B
P
Tổng hợp dữ liệu từ các sheet theo chọn lọc
Trả lời
12
Đọc
215
ptm0412
ptm0412
C
Công thức tự nhập liệu số lượng nhập khi bị âm
Trả lời
1
Đọc
74
hoangtuaotrang_hp_vn
H
kimtanmap
  • Question
Nhờ viết code VBA Macro lập lại.
Trả lời
5
Đọc
141
kimtanmap
kimtanmap
dung09031989
Xin giúp công thức tô màu các ô phía sau khi kế hoạch đặt hàng thiếu so với tồn kho.?
Trả lời
1
Đọc
70
hoangtuaotrang_hp_vn
H
huynhnhu1234
Tìm giá vé máy bay một chiều và khứ hồi
Trả lời
0
Đọc
39
huynhnhu1234
huynhnhu1234
V
[Nhờ giúp đỡ] Cách tìm thời gian bị trùng trong excel ở nhiều thời gian khác nhau
Trả lời
7
Đọc
122
tranvansau278
T
N
Hàm tìm giá trị theo giờ vào - ra
Trả lời
6
Đọc
111
Nguyễn Linh hn94
N
zarra
Cần giúp tạo form in mã vạch cho vật tư theo SL cụ thể.
Trả lời
4
Đọc
156
zarra
zarra
Nguyễn Duy Tuân
  • Question
Chia sẻ ControlForOffice - Bộ công cụ điều khiển Office/Excel
    • Thích
6 7 8
Trả lời
148
Đọc
95K
leminhksvl
L
HeSanbi
  • Question
Lỗi VBA: Cài đặt thông số ForceVBALoadFromSource trong Registry để VBA biên dịch không bị lỗi
    • Cảm ơn
    • Thích
Trả lời
5
Đọc
290
anhdepjai
A
H
Hàm đếm số ngày thứ bảy và chủ nhật trong một khoảng thời gian
Trả lời
18
Đọc
20K
DeTong
D
ongke0711
  • Question
Tải hóa đơn điện tử (https://hoadondientu.gdt.gov.vn/) Excel Vba
    • Thích
    • Yêu thích
11 12 13
Trả lời
245
Đọc
13K
Hoàng Trọng Hữu
Hoàng Trọng Hữu
D
  • Question
Xin cách sắp xếp dữ liệu theo thứ tự không làm hỏng link
Trả lời
7
Đọc
302
cantl
C
N
Giúp sửa mã code
Trả lời
16
Đọc
284
ptm0412
ptm0412
N
Vẽ biểu đồ kết hợp nhiều yếu tố trong excel
Trả lời
1
Đọc
65
hoangminhtien
hoangminhtien
Xem thêm…

Thành viên có số lượng bài viết cao nhất tháng

Thành viên có điểm tương tác cao nhất tháng

Back
Top Bottom