Vba Nhập ảnh vào Excel - Jpeg, Gif, Tiff, Png, v.v. từ Thư mục và Sắp xếp Ảnh cũ và Đến hàng Cuối cùng

Xin chào,

Đưa ra mẫu nhập mã Vba Tất cả hình ảnh từ Thư mục sang trang tính excel và sau khi nhập hình ảnh và Điều chỉnh theo Kích thước tùy chỉnh như Chiều cao: 20,32 cm và Chiều rộng 36,14 cm, Chiều cao tỷ lệ: 88% và Chiều rộng tỷ lệ 92% và cũng có đường viền ô Viền. chèn bắt đầu Từ A1, nếu việc thêm Ảnh mới vào cùng một trang tính không ảnh hưởng đến ảnh cũ, Ảnh mới được thêm vào Hàng cuối cùng.

nếu trang ngoài cột A1, nếu có hình nào ở đó, cũng được sắp xếp và đến hàng Cuối cùng. tôi đã tải lên tệp mẫu liên kết dưới đây

https://1drv.ms/x/s!AqIYf-7mjNDsgXHi3zO7mBoVle4p?e=fqHiiv

Câu trả lời:

Xin chào CV của Jeovany,

Công việc tốt đẹp, chắc chắn giúp ích cho việc quản lý chứng khoán. nhưng bạn có thêm nhận xét được thêm vào Tên trong mã vba, nếu Hình ảnh có thể Tên sẽ xuất hiện trong cột B2. bạn đã bỏ qua một số Mã, nếu có Hình ảnh   được đưa vào lịch phát sóng ngoài cột A1, được sắp xếp ( Kích thước tùy chỉnh như Chiều cao: 20,32 cm và Chiều rộng 36,14 cm, Chiều cao tỷ lệ: 88% và Chiều rộng tỷ lệ 92% và cũng có đường viền ô Viền) và nằm dưới hàng cuối cùng được thêm vào cột A1. Cảm ơn bạn Một lần nữa cho bạn ... Mã này giúp ích cho tất cả mọi người .. Tình huống khác nhau ...

.

>

Hari thân mến

Về:

"... nếu Tên hình ảnh có thể xuất hiện trong các cột B2."

CÓ, không có vấn đề gì mã bên dưới đã được sửa.

Về:

"... bạn đã bỏ qua một số Mã , nếu bất kỳ Hình ảnh nào vượt quá cột A1, được sắp xếp (Kích thước tùy chỉnh như Chiều cao: 20,32 cm và Chiều rộng 36,14 cm, Chiều cao tỷ lệ: 88% và Chiều rộng tỷ lệ 92% và cũng có Đường viền đường viền ô) và đi kèm dưới hàng cuối cùng được thêm trong cột A1.

Tôi không biết tại sao bạn nói rằng tôi đã bỏ qua một số mã.

Có lẽ bạn cần biết và lưu ý,

rằng những hình ảnh bạn muốn nhập để vượt trội, chúng phải có cùng kích thước W x L

Bạn phải cắt ảnh theo cùng kích thước bằng phần mềm hình ảnh khác như Photoshop

Hình ảnh dưới đây cho bạn thấy Kích thước của những hình ảnh tôi đã sử dụng trong tệp mẫu của bạn

Tất cả các hình ảnh có kích thước khác nhau (kích thước)

Và đây là những gì sẽ xảy ra khi bạn bán lại sau đó theo yêu cầu của bạn

Như bạn nhận thấy trong hình, không phải tất cả các lá cờ đều có hình dạng và kích thước giống nhau

Vì vậy, đây là điều bạn phải làm (sửa chữa) trước khi chạy macro

IMHO, Điều này không thể được thực hiện với VBA

Tôi đã thực hiện một số điều chỉnh đối với mã.

Đây là thành quả với những hình ảnh mình có được bên mình

Tên hình ảnh nằm trong cột B

Đường viền trong các ô trong cột A hiển thị rõ hơn

Về:

"... Cảm ơn Bạn một lần nữa cho bạn ... Mã này giúp ích cho tất cả mọi người .. Tình huống khác nhau ..."

Nếu câu trả lời đã giúp bạn.

Vui lòng xem xét đánh dấu chủ đề này là đã trả lời.

Nó sẽ giúp những người khác trong cộng đồng có những câu hỏi hoặc vấn đề tương tự.

Cảm ơn bạn trước

Đây là mã

************************************************** *************************************************

Sub InsertPicturesfromFolder ()

Dim Lrow As Long

Dim picRng As Range

Dim fPicker As FileDialog

Làm mờ thư mụcPath As String

Dim ảnhName As Variant

'' Phần 1: Chọn thư mục

Đặt fPicker = Application.FileDialog (msoFileDialogFolderPicker)

fPicker.AllowMultiSelect = Sai

fPicker.Show

folderPath = fPicker.SelectedItems (1) & "\" '' đường dẫn thư mục

pictureName = Dir (folderPath) '' 'tên của tệp (ảnh)

Application.ScreenUpdating = Sai

'' Phần 2: Lặp qua các tệp (ảnh) trong thư mục đã chọn

Do Until pictureName = ""

'' Hàng được sử dụng cuối cùng trong cột B

Lrow = ActiveSheet.Cells (Rows.Count, "B"). End (xlUp) .Row

Đặt pictureRng = Range ("A" & Lrow + 1)

'' 'Định dạng ô theo yêu cầu

Với ảnhRng

.Offset (0, 1) .Value = pictureName

.ColumnWidth = 26,88

.RowHeight = 84

.Borders (xlDiricalDown) .LineStyle = xlNone

.Borders (xlDiricalUp) .LineStyle = xlNone

Với .Borders (xlEdgeLeft)

.LineStyle = xlContinuous

.ColorIndex = 0

.TintAndShade = 0

.Weight = xlMedium

Kết thúc với

Với .Borders (xlEdgeTop)

.LineStyle = xlContinuous

.ColorIndex = 0

.TintAndShade = 0

.Weight = xlMedium

Kết thúc với

Với .Borders (xlEdgeBottom)

.LineStyle = xlContinuous

.ColorIndex = 0

.TintAndShade = 0

.Weight = xlMedium

Kết thúc với

Với .Borders (xlEdgeRight)

.LineStyle = xlContinuous

.ColorIndex = 0

.TintAndShade = 0

.Weight = xlMedium

Kết thúc với

.Borders (xlInsideVertical) .LineStyle = xlNone

.Borders (xlInsideHorizontal) .LineStyle = xlNone

Kết thúc với

'' '' Thêm nhận xét vào ô

Với ảnhRng.AddComment

.Vible = False

.Text pictureName

Kết thúc với

'' Phần 3: Chèn ảnh vào ô

Làm mờ myPic

Đặt myPic = ActiveSheet.Shapes.AddPicture (Tên tệp: = folderPath & pictureName, _

linktofile: = msoFalse, savewithdocument: = msoCTrue, Left: = 1, Top: = 1, Width: = - 1, Height: = - 1)

'' Định dạng ảnh theo yêu cầu

myPic.Select

Selection.ShapeRange.LockAspectRatio = msoTrue

Selection.ShapeRange.ScaleHeight 0,88, msoFalse, msoScaleFromTopLeft

Selection.ShapeRange.ScaleWidth 0,92, msoFalse, msoScaleFromTopLeft

Selection.Left = pictureRng.Left + 5

Selection.Top = pictureRng.Top + 5

Selection.Width = pictureRng.Width - 10

Selection.Height = pictureRng.Height - 10

pictureName = Dir

Vòng

Đặt fPicker = Không có gì

'' 'Định dạng cột B

Cột ("B: B"). HorizontalAlignment = xlCenter

Cột ("B: B"). VerticalAlignment = xlCenter

Cột ("B: B"). WrapText = True

Application.ScreenUpdating = True

MsgBox "Hoàn thành công việc"

Kết thúc Sub

> ************************************************* ************************************************** ***

Trân trọng

Jeovany