Mình có file gồm cột A (họ tên) và cột B (hình ảnh). File này là do chi nhánh gửi về. Do làm thủ công nên hình ảnh có thể không vừa khít ô. Mình nhờ moi người giúp đỡ đoạn code hoặc công cụ nào có thể xử lý ảnh hàng loạt cho vừa khít ô ở cột B.
Em chào các bác, hiện em có mò mầm làm cái hàm dò tìm ảnh trong excel để dễ in ấn, nhưng có điều là khi dò ra được thì ảnh ko fit được khung in và nếu em kéo ảnh ra thì nó rất mờ ko rõ nét như ảnh ở sheet DATA (file đính kèm). Các bác cao thủ trong đây cho em xin giải pháp xử lý, nếu xử lý được...
Em chào các bác, hiện em có mò mầm làm cái hàm dò tìm ảnh trong excel để dễ in ấn, nhưng có điều là khi dò ra được thì ảnh ko fit được khung in và nếu em kéo ảnh ra thì nó rất mờ ko rõ nét như ảnh ở sheet DATA (file đính kèm). Các bác cao thủ trong đây cho em xin giải pháp xử lý, nếu xử lý được...
Mình đã đọc nhưng do trình độ kém nên không làm được (cụ thể là không biết copy code nào và vào đâu). Mình chỉ cần đoạn code đơn giản để chỉnh kích thước hàng loạt ảnh vừa khít ô ở cột B (file này mình nhận từ người khác) thì sẽ copy code nào . Mong bạn hỗ trợ
Mình đã đọc nhưng do trình độ kém nên không làm được (cụ thể là không biết copy code nào và vào đâu). Mình chỉ cần đoạn code đơn giản để chỉnh kích thước hàng loạt ảnh vừa khít ô ở cột B (file này mình nhận từ người khác) thì sẽ copy code nào . Mong bạn hỗ trợ
Chào bạn, Mình đã thử nhiều lần nhưng vẫn không được, mong bạn thông cảm. Mình đành copy lại đoạn code của bạn và chỉnh sửa lại tí xíu. Hiện giờ đoạn code đã căn giữa tất cả hình ảnh trong cột B của Sheet1. Bạn có thể giúp mình thêm đoạn code để kéo hình ảnh đều về 2 phía trái và phải, mục đích là để hình ảnh lấp đầy cả ô. Cám ơn bạn rất nhiều.
Chào bạn, Mình đã thử nhiều lần nhưng vẫn không được, mong bạn thông cảm. Mình đành copy lại đoạn code của bạn và chỉnh sửa lại tí xíu. Hiện giờ đoạn code đã căn giữa tất cả hình ảnh trong cột B của Sheet1. Bạn có thể giúp mình thêm đoạn code để kéo hình ảnh đều về 2 phía trái và phải, mục đích là để hình ảnh lấp đầy cả ô. Cám ơn bạn rất nhiều.
Chào bạn, như trong bài đăng mình có ghi "Mình có file gồm cột A (họ tên) và cột B (hình ảnh). File này là do chi nhánh gửi về". Tức là file (mình nhận) đã có sẵn hình ảnh trong đó (nên mình không cần insert hình ảnh vào file này nữa). Cám ơn bạn đã hỗ trợ mình.
Mình có file gồm cột A (họ tên) và cột B (hình ảnh). File này là do chi nhánh gửi về. Do làm thủ công nên hình ảnh có thể không vừa khít ô. Mình nhờ moi người giúp đỡ đoạn code hoặc công cụ nào có thể xử lý ảnh hàng loạt cho vừa khít ô ở cột B.
Sub resize_pic()
Dim shp As Shape
Dim sh As Worksheet
Dim khung As Range
Set sh = Sheets("Sheet1")
For Each shp In sh.Shapes
Set khung = shp.TopLeftCell
With shp
.LockAspectRatio = 0
' .ScaleWidth 1, msoTrue
' .ScaleHeight 1, msoTrue
.Left = khung.Left
.Top = khung.Top
.Width = khung.Width
.Height = khung.Height
End With
Next shp
End Sub
Mình có file gồm cột A (họ tên) và cột B (hình ảnh). File này là do chi nhánh gửi về. Do làm thủ công nên hình ảnh có thể không vừa khít ô. Mình nhờ moi người giúp đỡ đoạn code hoặc công cụ nào có thể xử lý ảnh hàng loạt cho vừa khít ô ở cột B.
Mình có file gồm cột A (họ tên) và cột B (hình ảnh). File này là do chi nhánh gửi về. Do làm thủ công nên hình ảnh có thể không vừa khít ô. Mình nhờ moi người giúp đỡ đoạn code hoặc công cụ nào có thể xử lý ảnh hàng loạt cho vừa khít ô ở cột B.
Làm liên quan tới shapes có thể bạn sẽ phải quan tâm một số vấn đề:
1/ Hình trong file không nằm theo đúng chiều thuận, mà có thể họ đã xoay 90 hay 270 độ
2/ Có thể trong file có nhiều shape, mà không nhất thiết vùng nào cũng xử lý, nên khi xử lý cần chọn vùng cụ thể (tùy mục đích)
3/ Nên tính tâm shape làm căn cứ chọn ô có lẽ phù hợp hơn góc trên bên trái, vì đôi khi họ để lệch shape một xíu ra ô khác, góc trên trái sẽ sang ô khác so với tâm
Mình chỉ nói để bạn cân nhắc thôi
Sub resize_pic()
Dim shp As Shape
Dim sh As Worksheet
Dim khung As Range
Set sh = Sheets("Sheet1")
For Each shp In sh.Shapes
Set khung = shp.TopLeftCell
With shp
.LockAspectRatio = 0
' .ScaleWidth 1, msoTrue
' .ScaleHeight 1, msoTrue
.Left = khung.Left
.Top = khung.Top
.Width = khung.Width
.Height = khung.Height
End With
Next shp
End Sub
[/QUOTE]
Thầy @batman1 ơi. Em chạy lệnh thì tất cả các shapes vừa khung giờ em muốn nó chỉ kích vào shapes nào thì shapes đó vừa khung, shapes còn lại giữ nguyên
Lần sau viết bài ngoài đoạn trích nhé. Nếu không biết sử dụng diễn đàn thì trước tiên phải học cách sử đụng.
Thầy @batman1 ơi. Em chạy lệnh thì tất cả các shapes vừa khung giờ em muốn nó chỉ kích vào shapes nào thì shapes đó vừa khung, shapes còn lại giữ nguyên
1. Khi muốn vừa khít chỉ những ô được chọn (chọn 1, 2 hoặc tất cả) thì chọn chúng rồi thực hiện sub resize_selected_pic. Sub resize_selected_pic được chạy cho ActiveSheet.
2. Khi muốn vừa khít ô cho tất cả thì chạy sub resize_all_pic. Sub resize_all_pic được chạy cho các picture trên sheet Sheet1 (tên sheet trong code của sub), nếu cần thì thay đổi.
Cả sub resize_selected_pic và sub resize_all_pic đều gọi sub resize_one_pic để thực thi cho từng picture.
3. Phải đảm bảo sao cho góc trên bên trái của picture nằm gọn trong khung. Nếu thấy có vấn đề thì dùng chuột kéo picture sang phải và xuống dưới một tí tẹo để góc trên bên trái của picture nằm gọn trong khung.
4. Code
Mã:
Sub resize_one_pic(ByVal pic As Shape) ' sub tong quat de goi vua khit khung cho hoac nhieu duoc chon, hoac cho tat ca
Dim khung As Range
Set khung = pic.TopLeftCell
With pic
.LockAspectRatio = 0
.Left = khung.Left
.Top = khung.Top
.Width = khung.Width
.Height = khung.Height
End With
End Sub
Sub resize_selected_pic() ' chon 1 hoac nhieu de cho vua khit khung
Dim a
If TypeName(Selection) = "Picture" Then
resize_one_pic ActiveSheet.Shapes(Selection.ShapeRange.Name)
Else
For Each a In Selection
If TypeName(a) = "Picture" Then resize_one_pic ActiveSheet.Shapes(a.Name)
Next
End If
End Sub
Sub resize_all_pic() ' vua khit khung cho tat ca
Dim shp As Shape, sh As Worksheet
Set sh = ThisWorkbook.Worksheets("Sheet1")
For Each shp In sh.Shapes
resize_one_pic shp
Next shp
End Sub
Lưu ý:
1. Code ở trên chỉ định vị chính xác khi góc trên bên trái của ảnh nằm gọn trong khung. Nếu góc đó nằn lẹm sang ô cùng dòng nhưng ở cột trước hoặc / và ô cùng cột nhưng ở dòng trước thì code cho là ô cùng dòng nhưng ở cột trước hoặc / và ô cùng cột nhưng ở dòng trước là khung.
Vì việc đảm bảo yêu cầu góc trên bên trái của ảnh nằm gọn trong khung đòi hỏi những thao tác thêm nên ta có thể giải quyết như sau để bỏ các thao tác thêm. Nếu ta chấp nhận tâm (điểm đối xứng của hình chữ nhật) của ảnh luôn được coi là thuộc về khung, tức khung là ô chứa tâm, thì chỉ cần thêm vào trước dòng Set khung = pic.TopLeftCell trong sub resize_one_pic code
Mã:
With pic
.Left = .Left + .Width / 2
.Top = .Top + .Height / 2
End With
2. Code ở trên dành cho ảnh được chèn theo cách: thẻ Insert -> Picture -> chọn ảnh, tức ảnh thuộc "Picture". Nhưng cũng có thể: Insert -> Shapes -> chọn Rectangle -> vẽ hình chữ nhật trên sheet -> phải chuột trên hình chữ nhật -> Format Shape -> FILL -> chọn "Picture or texture fill" -> File ... -> chọn ảnh. Nếu muốn phục vụ cả "Rectangle" thì thêm Or TypeName(Selection) = "Rectangle" trong Sub resize_selected_pic.
Code sau khi sửa như sau. Nếu không muốn điểm 1 thì xóa code thêm vào ở sub resize_one_pic. Nếu không muốn điểm 2 thì xóa code thêm vào ở Sub resize_selected_pic
Mã:
Sub resize_one_pic(ByVal pic As Shape) ' sub tong quat de goi vua khit khung cho hoac nhieu duoc chon, hoac cho tat ca
Dim khung As Range
With pic
.Left = .Left + .Width / 2
.Top = .Top + .Height / 2
End With
Set khung = pic.TopLeftCell
With pic
.LockAspectRatio = 0
.Left = khung.Left
.Top = khung.Top
.Width = khung.Width
.Height = khung.Height
End With
End Sub
Sub resize_selected_pic() ' chon 1 hoac nhieu de cho vua khit khung
Dim a
If TypeName(Selection) = "Picture" Or TypeName(Selection) = "Rectangle" Then
resize_one_pic ActiveSheet.Shapes(Selection.ShapeRange.Name)
Else
For Each a In Selection
If TypeName(a) = "Picture" Or TypeName(a) = "Rectangle" Then resize_one_pic ActiveSheet.Shapes(a.Name)
Next
End If
End Sub
Lần sau viết bài ngoài đoạn trích nhé. Nếu không biết sử dụng diễn đàn thì trước tiên phải học cách sử đụng.
1. Khi muốn vừa khít chỉ những ô được chọn (chọn 1, 2 hoặc tất cả) thì chọn chúng rồi thực hiện sub resize_selected_pic. Sub resize_selected_pic được chạy cho ActiveSheet.
2. Khi muốn vừa khít ô cho tất cả thì chạy sub resize_all_pic. Sub resize_all_pic được chạy cho các picture trên sheet Sheet1 (tên sheet trong code của sub), nếu cần thì thay đổi.
Cả sub resize_selected_pic và sub resize_all_pic đều gọi sub resize_one_pic để thực thi cho từng picture.
3. Phải đảm bảo sao cho góc trên bên trái của picture nằm gọn trong khung. Nếu thấy có vấn đề thì dùng chuột kéo picture sang phải và xuống dưới một tí tẹo để góc trên bên trái của picture nằm gọn trong khung.
4. Code
Mã:
Sub resize_one_pic(ByVal pic As Shape) ' sub tong quat de goi vua khit khung cho hoac nhieu duoc chon, hoac cho tat ca
Dim khung As Range
Set khung = pic.TopLeftCell
With pic
.LockAspectRatio = 0
.Left = khung.Left
.Top = khung.Top
.Width = khung.Width
.Height = khung.Height
End With
End Sub
Sub resize_selected_pic() ' chon 1 hoac nhieu de cho vua khit khung
Dim a
If TypeName(Selection) = "Picture" Then
resize_one_pic ActiveSheet.Shapes(Selection.ShapeRange.Name)
Else
For Each a In Selection
If TypeName(a) = "Picture" Then resize_one_pic ActiveSheet.Shapes(a.Name)
Next
End If
End Sub
Sub resize_all_pic() ' vua khit khung cho tat ca
Dim shp As Shape, sh As Worksheet
Set sh = ThisWorkbook.Worksheets("Sheet1")
For Each shp In sh.Shapes
resize_one_pic shp
Next shp
End Sub
Lưu ý:
1. Code ở trên chỉ định vị chính xác khi góc trên bên trái của ảnh nằm gọn trong khung. Nếu góc đó nằn lẹm sang ô cùng dòng nhưng ở cột trước hoặc / và ô cùng cột nhưng ở dòng trước thì code cho là ô cùng dòng nhưng ở cột trước hoặc / và ô cùng cột nhưng ở dòng trước là khung.
Vì việc đảm bảo yêu cầu góc trên bên trái của ảnh nằm gọn trong khung đòi hỏi những thao tác thêm nên ta có thể giải quyết như sau để bỏ các thao tác thêm. Nếu ta chấp nhận tâm (điểm đối xứng của hình chữ nhật) của ảnh luôn được coi là thuộc về khung, tức khung là ô chứa tâm, thì chỉ cần thêm vào trước dòng Set khung = pic.TopLeftCell trong sub resize_one_pic code
Mã:
With pic
.Left = .Left + .Width / 2
.Top = .Top + .Height / 2
End With
2. Code ở trên dành cho ảnh được chèn theo cách: thẻ Insert -> Picture -> chọn ảnh, tức ảnh thuộc "Picture". Nhưng cũng có thể: Insert -> Shapes -> chọn Rectangle -> vẽ hình chữ nhật trên sheet -> phải chuột trên hình chữ nhật -> Format Shape -> FILL -> chọn "Picture or texture fill" -> File ... -> chọn ảnh. Nếu muốn phục vụ cả "Rectangle" thì thêm Or TypeName(Selection) = "Rectangle" trong Sub resize_selected_pic.
Code sau khi sửa như sau. Nếu không muốn điểm 1 thì xóa code thêm vào ở sub resize_one_pic. Nếu không muốn điểm 2 thì xóa code thêm vào ở Sub resize_selected_pic
Mã:
Sub resize_one_pic(ByVal pic As Shape) ' sub tong quat de goi vua khit khung cho hoac nhieu duoc chon, hoac cho tat ca
Dim khung As Range
With pic
.Left = .Left + .Width / 2
.Top = .Top + .Height / 2
End With
Set khung = pic.TopLeftCell
With pic
.LockAspectRatio = 0
.Left = khung.Left
.Top = khung.Top
.Width = khung.Width
.Height = khung.Height
End With
End Sub
Sub resize_selected_pic() ' chon 1 hoac nhieu de cho vua khit khung
Dim a
If TypeName(Selection) = "Picture" Or TypeName(Selection) = "Rectangle" Then
resize_one_pic ActiveSheet.Shapes(Selection.ShapeRange.Name)
Else
For Each a In Selection
If TypeName(a) = "Picture" Or TypeName(a) = "Rectangle" Then resize_one_pic ActiveSheet.Shapes(a.Name)
Next
End If
End Sub
. Mong bạn hỗ trợ 
