hình như bạn muốn tự động tạo CV à?
sao không làm tool chạy cả danh sách (điều kiện: ảnh được đặt tên theo quy tắc, ví dụ: stt-tên -> 1.Nguyễn Văn A.xlsx) ?
làm như vậy sẽ không mất công chọn ảnh (nhưng mất công sửa tên file ảnh) và tạo ra sheet theo stt luôn.
hình như bạn muốn tự động tạo CV à?
sao không làm tool chạy cả danh sách (điều kiện: ảnh được đặt tên theo quy tắc, ví dụ: stt-tên -> 1.Nguyễn Văn A.xlsx) ?
làm như vậy sẽ không mất công chọn ảnh (nhưng mất công sửa tên file ảnh) và tạo ra sheet theo stt luôn.
dạ không cái đó em biết làm rồi ạ.
hiện tại thì em đang làm cái này ạ. nhưng nhiều bước quá nên em muốn nhờ các anh chị chỉnh giúp em giản lược đi 2 bước ạ.
thế thì như này:
-theo mình để 1 sheet là CV
-khi lấy ảnh, copy sheet CV đó, đổi tên sheet rồi chèn ảnh vào (vậy là khỏi lo xóa ảnh)
muốn stt tăng thì để 1 biến truyền vào thôi
Mã:
Sheets("CV").Copy After:=Sheets(Sheets.Count)
ActiveSheet.Name = ten
thế thì như này:
-theo mình để 1 sheet là CV
-khi lấy ảnh, copy sheet CV đó, đổi tên sheet rồi chèn ảnh vào (vậy là khỏi lo xóa ảnh)
muốn stt tăng thì để 1 biến truyền vào thôi
Mã:
Sheets("CV").Copy After:=Sheets(Sheets.Count)
ActiveSheet.Name = ten
Bạn thử chạy theo code này xem
(phần kích thước ảnh bạn phải tự căn chỉnh lại)
Mã:
Sub bPic()
Dim nameSheet As Integer, addressPic As String
Dim p As Object
nameSheet = Sheets("Nhap Anh").Range("B1").Value
addressPic = Browse_PICFILE
Sheets("CV").Copy After:=Sheets(Sheets.Count)
ActiveSheet.Name = nameSheet
Set p = ActiveSheet.Shapes.AddPicture(addressPic, True, True, 0, 0, 353, 117)
With p
.Left = Range("A1").Left + (Range("A1:B1").Width - 353) / 2
.Top = Range("A1").Top + (Range("A1:B1").Height - 100) / 2
End With
Sheets("Nhap Anh").Range("B1") = nameSheet + 1
End Sub
Bạn thử chạy theo code này xem
(phần kích thước ảnh bạn phải tự căn chỉnh lại)
Mã:
Sub bPic()
Dim nameSheet As Integer, addressPic As String
Dim p As Object
nameSheet = Sheets("Nhap Anh").Range("B1").Value
addressPic = Browse_PICFILE
Sheets("CV").Copy After:=Sheets(Sheets.Count)
ActiveSheet.Name = nameSheet
Set p = ActiveSheet.Shapes.AddPicture(addressPic, True, True, 0, 0, 353, 117)
With p
.Left = Range("A1").Left + (Range("A1:B1").Width - 353) / 2
.Top = Range("A1").Top + (Range("A1:B1").Height - 100) / 2
End With
Sheets("Nhap Anh").Range("B1") = nameSheet + 1
End Sub
Em hiểu ý của anh. Nhưng các sheet 1,2,3 là các sheet có sẵn ạ. không phải tạo từ CV gốc.
File gốc chỉ cần nhảy số ở bước 1 là nó sẽ tự động nhảy ảnh vào các sheet đó ạ.
e thấy bước 4 đã được giản lướt rồi ạ
Anh giúp em thêm vụ bước một tự nhảy 1,2,3,4 theo thứ tự setupban đầu khi ấn bước 3 Lưu ảnh đi ạ.
Mình xác nhận lại vấn đề của bạn nhớ.
File của bạn có nhiều sheets giống nhau, mỗi sheets CHỈ có MỘT ảnh ở ô "AW4".
Sheet "Nhap Anh" sẽ điều khiển để thay ảnh ở sheet được chọn.
Thay ảnh theo quy trình: chọn ảnh -> xóa ảnh cũ -> thay ảnh mới
Sau khi thay ảnh, stt sẽ tăng lên 1.
@@ sao từ đầu bạn không nói rõ là các sheet đã có sẵn?
Mà bản mình gửi đã tự tăng stt lên 1 rồi mà??
Mình xác nhận lại vấn đề của bạn nhớ.
File của bạn có nhiều sheets giống nhau, mỗi sheets CHỈ có MỘT ảnh ở ô "AW4".
Sheet "Nhap Anh" sẽ điều khiển để thay ảnh ở sheet được chọn.
Thay ảnh theo quy trình: chọn ảnh -> xóa ảnh cũ -> thay ảnh mới
Sau khi thay ảnh, stt sẽ tăng lên 1.
Chạy được rồi anh ạ. nhưng anh cho em hỏi nó hiện lên như thế này có vấn đề gì không ạ
Bài đã được tự động gộp:
Sub DeletePics()
Dim shp As Shape
Set ws = ActiveSheet
Set Rng = ws.Range("E2:E3")
Application.ScreenUpdating = False
For Each shp In ws.Shapes
With shp
If .Name Like "Picture*" Then
s = .TopLeftCell.Address & ":" & .BottomRightCell.Address
If Not Intersect(Rng, ws.Range(s)) Is Nothing Then
shp.Delete
End If
End If
End With
Next
Application.ScreenUpdating = True
End Sub
Bây giờ em sử dụng nút xoá ảnh để xoá các ảnh trong sheet 1 trở đi thì thay như thế nào ạ.
ví dụ em muốn xoá hàng loạt ảnh của vùng AW4 từ sheet 1->sheet 5
Anh hướng dẫn em với ạ. em mong muốn code chỉ định rõ số sheet có ảnh mình cần xoá hàng loạt ạ./
Bây giờ em sử dụng nút xoá ảnh để xoá các ảnh trong sheet 1 trở đi thì thay như thế nào ạ.
ví dụ em muốn xoá hàng loạt ảnh của vùng AW4 từ sheet 1->sheet 5
Anh hướng dẫn em với ạ. em mong muốn code chỉ định rõ số sheet có ảnh mình cần xoá hàng loạt ạ./
Do code của bạn dùng Pictures.Insert nên khi lưu tập tin -> đóng tập tin -> xóa ảnh trên đĩa -> mở lại tập tin thì sẽ có như trong ảnh đính kèm. Tức không được xóa ảnh trên đĩa, không được chuyển sang chỗ khác. Lý do là ảnh không được nhập vào hẳn mà chỉ được kết nối thôi.
Sub InsertPicture(ByVal PicFilename As String, Optional Target As range = Nothing, _
Optional original As Boolean = False, Optional center As Boolean = False, _
Optional LinkToFile As Boolean = False)
' Target: vung nhap anh. Co the la nhieu cell
' Neu Target = Nothing thi Target = ActiveCell
' Neu original = True thi nhap anh kich thuoc thuc.
' Neu original = FALSE thi neu center = True thi anh se center trong vung Target,
' nguoc lai thi se vua khit vung Target
' LinkToFile = False thi khong can giu anh tren dia, nguoc lai bat buoc phai giu anh de moi lan mo thi co
Dim w As Double, h As Double, shp As Shape, fso As Object
If Target Is Nothing Then Set Target = ActiveCell
On Error Resume Next
Target.Parent.Shapes(Target.Address).Delete
On Error GoTo 0
Set fso = CreateObject("Scripting.FileSystemObject")
If fso.FileExists(PicFilename) Then
If LinkToFile Then
Set shp = Target.Parent.Shapes.AddPicture(PicFilename, msoTrue, msoFalse, Target.left, Target.top, 0, 0)
Else
Set shp = Target.Parent.Shapes.AddPicture(PicFilename, msoFalse, msoTrue, Target.left, Target.top, 0, 0)
End If
If Not shp Is Nothing Then
With shp
If original Then
.ScaleWidth 1, msoTrue
.ScaleHeight 1, msoTrue
ElseIf center Then
.ScaleWidth 1, msoTrue
.ScaleHeight 1, msoTrue
w = Target.Width
h = w * .Height / .Width
If h > Target.Height Then
h = Target.Height
w = h * .Width / .Height
End If
.left = Target.left + (Target.Width - w) / 2
.top = Target.top + (Target.Height - h) / 2
.Width = w
.Height = h
Else
.Width = Target.Width
.Height = Target.Height
End If
shp.Name = Target.Address
shp.Placement = xlMoveAndSize
End With
End If
End If
Set fso = Nothing
End Sub
Sub LayAnh()
Dim filename As String
filename = Browse_PICFILE
If Len(filename) Then InsertPicture filename, range("E2")
End Sub
3. Trong sub LuuAnh thay
ActiveSheet.Shapes.Range(Array([E2])).Select
bằng
ActiveSheet.Shapes.range("$E$2").Select
Bây giờ em sử dụng nút xoá ảnh để xoá các ảnh trong sheet 1 trở đi thì thay như thế nào ạ.
ví dụ em muốn xoá hàng loạt ảnh của vùng AW4 từ sheet 1->sheet 5
Anh hướng dẫn em với ạ. em mong muốn code chỉ định rõ số sheet có ảnh mình cần xoá hàng loạt ạ./
Sub DeleteSelectedPic()
Dim k As Long, sh As Worksheet, shp As Shape, Arr()
ReDim Arr(1 To ActiveWindow.SelectedSheets.Count)
For k = 1 To UBound(Arr)
Arr(k) = ActiveWindow.SelectedSheets(k).Name
Next k
ThisWorkbook.Worksheets("Nhap anh").Select
For k = 1 To UBound(Arr)
Set sh = ThisWorkbook.Worksheets(Arr(k))
For Each shp In sh.Shapes
If shp.TopLeftCell.Address = "$AW$4" Then
shp.Delete
Exit For
End If
Next shp
Next k
End Sub
2. Thao tác: Trên thanh "Sheets tab" chọn các sheet cần xóa ảnh -> chạy sub DeleteSelectedPic. Vd. bạn có sheet 1 đến 200 nhưng bạn chỉ muốn xóa ảnh trong 1, 2, 3, 12 thì bạn chỉ chọn 4 sheet đó rồi chạy sub DeleteSelectedPic (có thể gán macro DeleteSelectedPic cho nút nào đấy)
Do code của bạn dùng Pictures.Insert nên khi lưu tập tin -> đóng tập tin -> xóa ảnh trên đĩa -> mở lại tập tin thì sẽ có như trong ảnh đính kèm. Tức không được xóa ảnh trên đĩa, không được chuyển sang chỗ khác. Lý do là ảnh không được nhập vào hẳn mà chỉ được kết nối thôi.
Sub InsertPicture(ByVal PicFilename As String, Optional Target As range = Nothing, _
Optional original As Boolean = False, Optional center As Boolean = False, _
Optional LinkToFile As Boolean = False)
' Target: vung nhap anh. Co the la nhieu cell
' Neu Target = Nothing thi Target = ActiveCell
' Neu original = True thi nhap anh kich thuoc thuc.
' Neu original = FALSE thi neu center = True thi anh se center trong vung Target,
' nguoc lai thi se vua khit vung Target
' LinkToFile = False thi khong can giu anh tren dia, nguoc lai bat buoc phai giu anh de moi lan mo thi co
Dim w As Double, h As Double, shp As Shape, fso As Object
If Target Is Nothing Then Set Target = ActiveCell
On Error Resume Next
Target.Parent.Shapes(Target.Address).Delete
On Error GoTo 0
Set fso = CreateObject("Scripting.FileSystemObject")
If fso.FileExists(PicFilename) Then
If LinkToFile Then
Set shp = Target.Parent.Shapes.AddPicture(PicFilename, msoTrue, msoFalse, Target.left, Target.top, 0, 0)
Else
Set shp = Target.Parent.Shapes.AddPicture(PicFilename, msoFalse, msoTrue, Target.left, Target.top, 0, 0)
End If
If Not shp Is Nothing Then
With shp
If original Then
.ScaleWidth 1, msoTrue
.ScaleHeight 1, msoTrue
ElseIf center Then
.ScaleWidth 1, msoTrue
.ScaleHeight 1, msoTrue
w = Target.Width
h = w * .Height / .Width
If h > Target.Height Then
h = Target.Height
w = h * .Width / .Height
End If
.left = Target.left + (Target.Width - w) / 2
.top = Target.top + (Target.Height - h) / 2
.Width = w
.Height = h
Else
.Width = Target.Width
.Height = Target.Height
End If
shp.Name = Target.Address
shp.Placement = xlMoveAndSize
End With
End If
End If
Set fso = Nothing
End Sub
Sub LayAnh()
Dim filename As String
filename = Browse_PICFILE
If Len(filename) Then InsertPicture filename, range("E2")
End Sub
3. Trong sub LuuAnh thay
ActiveSheet.Shapes.Range(Array([E2])).Select
bằng
ActiveSheet.Shapes.range("$E$2").Select
1. Thêm code
Mã:
Sub DeleteSelectedPic()
Dim k As Long, sh As Worksheet, shp As Shape, Arr()
ReDim Arr(1 To ActiveWindow.SelectedSheets.Count)
For k = 1 To UBound(Arr)
Arr(k) = ActiveWindow.SelectedSheets(k).Name
Next k
ThisWorkbook.Worksheets("Nhap anh").Select
For k = 1 To UBound(Arr)
Set sh = ThisWorkbook.Worksheets(Arr(k))
For Each shp In sh.Shapes
If shp.TopLeftCell.Address = "$AW$4" Then
shp.Delete
Exit For
End If
Next shp
Next k
End Sub
2. Thao tác: Trên thanh "Sheets tab" chọn các sheet cần xóa ảnh -> chạy sub DeleteSelectedPic. Vd. bạn có sheet 1 đến 200 nhưng bạn chỉ muốn xóa ảnh trong 1, 2, 3, 12 thì bạn chỉ chọn 4 sheet đó rồi chạy sub DeleteSelectedPic (có thể gán macro DeleteSelectedPic cho nút nào đấy)
Bác bên trên hướng dẫn bạn dùng DeleteSelectedPic() rồi mà???
Thêm nữa, ở #12, mình đã hỏi bạn là muốn xóa 1 hay tất cả các ảnh thì bạn không trả lời???
Bác bên trên hướng dẫn bạn dùng DeleteSelectedPic() rồi mà???
Thêm nữa, ở #12, mình đã hỏi bạn là muốn xóa 1 hay tất cả các ảnh thì bạn không trả lời???
Do code của bạn dùng Pictures.Insert nên khi lưu tập tin -> đóng tập tin -> xóa ảnh trên đĩa -> mở lại tập tin thì sẽ có như trong ảnh đính kèm. Tức không được xóa ảnh trên đĩa, không được chuyển sang chỗ khác. Lý do là ảnh không được nhập vào hẳn mà chỉ được kết nối thôi.
Sub InsertPicture(ByVal PicFilename As String, Optional Target As range = Nothing, _
Optional original As Boolean = False, Optional center As Boolean = False, _
Optional LinkToFile As Boolean = False)
' Target: vung nhap anh. Co the la nhieu cell
' Neu Target = Nothing thi Target = ActiveCell
' Neu original = True thi nhap anh kich thuoc thuc.
' Neu original = FALSE thi neu center = True thi anh se center trong vung Target,
' nguoc lai thi se vua khit vung Target
' LinkToFile = False thi khong can giu anh tren dia, nguoc lai bat buoc phai giu anh de moi lan mo thi co
Dim w As Double, h As Double, shp As Shape, fso As Object
If Target Is Nothing Then Set Target = ActiveCell
On Error Resume Next
Target.Parent.Shapes(Target.Address).Delete
On Error GoTo 0
Set fso = CreateObject("Scripting.FileSystemObject")
If fso.FileExists(PicFilename) Then
If LinkToFile Then
Set shp = Target.Parent.Shapes.AddPicture(PicFilename, msoTrue, msoFalse, Target.left, Target.top, 0, 0)
Else
Set shp = Target.Parent.Shapes.AddPicture(PicFilename, msoFalse, msoTrue, Target.left, Target.top, 0, 0)
End If
If Not shp Is Nothing Then
With shp
If original Then
.ScaleWidth 1, msoTrue
.ScaleHeight 1, msoTrue
ElseIf center Then
.ScaleWidth 1, msoTrue
.ScaleHeight 1, msoTrue
w = Target.Width
h = w * .Height / .Width
If h > Target.Height Then
h = Target.Height
w = h * .Width / .Height
End If
.left = Target.left + (Target.Width - w) / 2
.top = Target.top + (Target.Height - h) / 2
.Width = w
.Height = h
Else
.Width = Target.Width
.Height = Target.Height
End If
shp.Name = Target.Address
shp.Placement = xlMoveAndSize
End With
End If
End If
Set fso = Nothing
End Sub
Sub LayAnh()
Dim filename As String
filename = Browse_PICFILE
If Len(filename) Then InsertPicture filename, range("E2")
End Sub
3. Trong sub LuuAnh thay
ActiveSheet.Shapes.Range(Array([E2])).Select
bằng
ActiveSheet.Shapes.range("$E$2").Select
1. Thêm code
Mã:
Sub DeleteSelectedPic()
Dim k As Long, sh As Worksheet, shp As Shape, Arr()
ReDim Arr(1 To ActiveWindow.SelectedSheets.Count)
For k = 1 To UBound(Arr)
Arr(k) = ActiveWindow.SelectedSheets(k).Name
Next k
ThisWorkbook.Worksheets("Nhap anh").Select
For k = 1 To UBound(Arr)
Set sh = ThisWorkbook.Worksheets(Arr(k))
For Each shp In sh.Shapes
If shp.TopLeftCell.Address = "$AW$4" Then
shp.Delete
Exit For
End If
Next shp
Next k
End Sub
2. Thao tác: Trên thanh "Sheets tab" chọn các sheet cần xóa ảnh -> chạy sub DeleteSelectedPic. Vd. bạn có sheet 1 đến 200 nhưng bạn chỉ muốn xóa ảnh trong 1, 2, 3, 12 thì bạn chỉ chọn 4 sheet đó rồi chạy sub DeleteSelectedPic (có thể gán macro DeleteSelectedPic cho nút nào đấy)
Cuối cùng có <vùng cần nhập ảnh> = <ô chứa đường dẫn tới ảnh ở cột A hoặc D>.Offset(-1, 1).MergeArea
------------
Những cái tôi viết ở trên nó chẳng liên quan gì tới nhập ảnh. Những cái đó là lập trình VBA, là cách viết code, là kinh nghiệm ...
Tóm lại là:
1. Code cho trường hợp cụ thể này, chỉ có 4 ảnh trong mỗi cột.
Mã:
Sub Nhap_sheet1()
Dim k As Long, c As Long
For c = 1 To 4 Step 3 ' c = 1 -> cot A, c = 4 -> cot D
For k = 1 To 4
If Len(Sheet1.Cells(4 * k, c).Value) Then
' duong dan khong rong -> nhap anh
InsertPicture ThisWorkbook.Path & "\" & Sheet1.Cells(4 * k, c).Value & ".jpg", Sheet1.Cells(4 * k, c).Offset(-1, 1).MergeArea
End If
Next k
Next c
End Sub
2. Code cho trường hợp TỔNG QUÁT, khi số ảnh hiện hành tùy ý, nhưng đường dẫn cũng ở các dòng có chỉ số là bội của 4, tức 4*k, và ở cột A và D
Mã:
Sub Nhap_sheet1()
Dim lastRow As Long, k As Long, c As Long
For c = 1 To 4 Step 3 ' c = 1 -> cot A, c = 4 -> cot D
lastRow = Sheet1.Cells(Rows.Count, c).End(xlUp).Row
For k = 1 To lastRow \ 4
If Len(Sheet1.Cells(4 * k, c).Value) Then
' duong dan khong rong -> nhap anh
InsertPicture ThisWorkbook.Path & "\" & Sheet1.Cells(4 * k, c).Value & ".jpg", Sheet1.Cells(4 * k, c).Offset(-1, 1).MergeArea
End If
Next k
Next c
End Sub
Cuối cùng có <vùng cần nhập ảnh> = <ô chứa đường dẫn tới ảnh ở cột A hoặc D>.Offset(-1, 1).MergeArea
------------
Những cái tôi viết ở trên nó chẳng liên quan gì tới nhập ảnh. Những cái đó là lập trình VBA, là cách viết code, là kinh nghiệm ...
Tóm lại là:
1. Code cho trường hợp cụ thể này, chỉ có 4 ảnh trong mỗi cột.
Mã:
Sub Nhap_sheet1()
Dim k As Long, c As Long
For c = 1 To 4 Step 3 ' c = 1 -> cot A, c = 4 -> cot D
For k = 1 To 4
If Len(Sheet1.Cells(4 * k, c).Value) Then
' duong dan khong rong -> nhap anh
InsertPicture ThisWorkbook.Path & "\" & Sheet1.Cells(4 * k, c).Value & ".jpg", Sheet1.Cells(4 * k, c).Offset(-1, 1).MergeArea
End If
Next k
Next c
End Sub
2. Code cho trường hợp TỔNG QUÁT, khi số ảnh hiện hành tùy ý, nhưng đường dẫn cũng ở các dòng có chỉ số là bội của 4, tức 4*k, và ở cột A và D
Mã:
Sub Nhap_sheet1()
Dim lastRow As Long, k As Long, c As Long
For c = 1 To 4 Step 3 ' c = 1 -> cot A, c = 4 -> cot D
lastRow = Sheet1.Cells(Rows.Count, c).End(xlUp).Row
For k = 1 To lastRow \ 4
If Len(Sheet1.Cells(4 * k, c).Value) Then
' duong dan khong rong -> nhap anh
InsertPicture ThisWorkbook.Path & "\" & Sheet1.Cells(4 * k, c).Value & ".jpg", Sheet1.Cells(4 * k, c).Offset(-1, 1).MergeArea
End If
Next k
Next c
End Sub
)
