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!
Nhờ các anh chị giúp ghép nhiều hình ảnh vào Excel
- Thread starter Kem88
- Ngày gửi
Nếu đã có code rồi thì sao không đính kèm để người ta chỉnh sửa hộ?
Upvote
0
đâ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
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
Upvote
0
huuthang_bd
Chuyên gia GPE
- Tham gia
- 10/9/08
- Bài viết
- 8,709
- Được thích
- 10,814
- Donate (Momo)
- Giới tính
- Nam
- Nghề nghiệp
- Thợ đụng
Bạn thử code này:
Mã:
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
Upvote
0
Mình thử được rồi cảm ơn bạn nhiều nhé!
Upvote
0
