Nhờ các anh chị giúp ghép nhiều hình ảnh vào Excel

[Kem88]

Do yêu cầu công việc nên e cần ghép nhiều ảnh vào 1 ô(đã gộp như ở file đính kèm),vba ghép 1 ảnh vào 1 ô thì e đã tham khảo được rồi nhưng món này e hơi dốt nên ko biết chỉnh sửa để áp dụng vào trường hợp này được.A/c chỉ giáo giùm e trường hợp này có code nào xài được không ạ.Em cảm ơn nhiều!

 

[snow25]

Do yêu cầu công việc nên e cần ghép nhiều ảnh vào 1 ô(đã gộp như ở file đính kèm),vba ghép 1 ảnh vào 1 ô thì e đã tham khảo được rồi nhưng món này e hơi dốt nên ko biết chỉnh sửa để áp dụng vào trường hợp này được.A/c chỉ giáo giùm e trường hợp này có code nào xài được không ạ.Em cảm ơn nhiều!

Bạn cho cái code cũ lên đây xem nào.Mà lấy theo kiểu gì.Cái kia thì chỉ chia nhỏ ô rồi điền ảnh vào theo kích cỡ là được.Bạn xác định tọa độ của các điểm cần điền ảnh vào.

 

[batman1]

Do yêu cầu công việc nên e cần ghép nhiều ảnh vào 1 ô(đã gộp như ở file đính kèm),vba ghép 1 ảnh vào 1 ô thì e đã tham khảo được rồi nhưng món này e hơi dốt nên ko biết chỉnh sửa để áp dụng vào trường hợp này được.A/c chỉ giáo giùm e trường hợp này có code nào xài được không ạ.Em cảm ơn nhiều!

Nếu đã có code rồi thì sao không đính kèm để người ta chỉnh sửa hộ?

 

[Kem88]

đây là code chèn ảnh theo hàng ngang ạ,nhưng code này chỉ áp dụng 1 ảnh 1 ô thôi ạ.còn nếu mà nó cho chia ô của em thành 4 ô nhỏ rồi chèn 4 cái ảnh vào thì lại dễ quá ạ.

Sub Ngang()
'Update 20140513
Dim password As Variant
Dim PicList() As Variant
Dim PicFormat As String
Dim Rng As Range
Dim sShape As Shape
On Error Resume Next
PicList = Application.GetOpenFilename(PicFormat, MultiSelect:=True)
xColIndex = Application.ActiveCell.Column
If IsArray(PicList) Then
xRowIndex = Application.ActiveCell.Row
For lLoop = LBound(PicList) To UBound(PicList)
Set Rng = Cells(xRowIndex, xColIndex).Resize(numRows + 1, numCols + 1)
Set sShape = ActiveSheet.Shapes.AddPicture(PicList(lLoop), msoFalse, msoCTrue, Rng.Left + 4, Rng.Top + 4, Rng.Width - 8, Rng.Height - 8)
xColIndex = xColIndex + 1
Next
End If
End Sub

 

[huuthang_bd]

Do yêu cầu công việc nên e cần ghép nhiều ảnh vào 1 ô(đã gộp như ở file đính kèm),vba ghép 1 ảnh vào 1 ô thì e đã tham khảo được rồi nhưng món này e hơi dốt nên ko biết chỉnh sửa để áp dụng vào trường hợp này được.A/c chỉ giáo giùm e trường hợp này có code nào xài được không ạ.Em cảm ơn nhiều!

Bạn thử code này:

Sub InsertPicsIntoCells(ByVal rCll As Range)
Const dPadding As Double = 4
Dim n As Long, dLeft As Double, dTop As Double, dPicWidth As Double, dPicHeight As Double
Set rCll = rCll.Cells(1, 1).MergeArea
With Application.FileDialog(msoFileDialogFilePicker)
    If Len(InitialPath) > 0 Then .InitialFileName = InitialPath
    .Filters.Clear
    .Filters.Add "Pictures", "*.jpg, *.jpeg"
    .AllowMultiSelect = True
    If .Show Then
        n = .SelectedItems.Count
        dLeft = rCll.Left
        dTop = rCll.Top
        dPicWidth = (rCll.Width - dPadding * (n + 1)) / n
        dPicHeight = rCll.Height - dPadding * 2
        For i = 1 To n
            rCll.Parent.Shapes.AddPicture .SelectedItems(i), msoFalse, msoCTrue, dLeft + dPadding * i + dPicWidth * (i - 1), dTop + dPadding, dPicWidth, dPicHeight
        Next
    End If
End With
End Sub
Sub Test()
InsertPicsIntoCells Selection
End Sub

 

[Kem88]

Bạn thử code này:

Sub InsertPicsIntoCells(ByVal rCll As Range)
Const dPadding As Double = 4
Dim n As Long, dLeft As Double, dTop As Double, dPicWidth As Double, dPicHeight As Double
Set rCll = rCll.Cells(1, 1).MergeArea
With Application.FileDialog(msoFileDialogFilePicker)
    If Len(InitialPath) > 0 Then .InitialFileName = InitialPath
    .Filters.Clear
    .Filters.Add "Pictures", "*.jpg, *.jpeg"
    .AllowMultiSelect = True
    If .Show Then
        n = .SelectedItems.Count
        dLeft = rCll.Left
        dTop = rCll.Top
        dPicWidth = (rCll.Width - dPadding * (n + 1)) / n
        dPicHeight = rCll.Height - dPadding * 2
        For i = 1 To n
            rCll.Parent.Shapes.AddPicture .SelectedItems(i), msoFalse, msoCTrue, dLeft + dPadding * i + dPicWidth * (i - 1), dTop + dPadding, dPicWidth, dPicHeight
        Next
    End If
End With
End Sub
Sub Test()
InsertPicsIntoCells Selection
End Sub

Mình thử được rồi cảm ơn bạn nhiều nhé!