[已解决]简历保存

hasyh2008

Private Sub Worksheet_Change(ByVal Target As Range)
  On Error Resume Next
  Dim Rg As Range
  Set Rg = Range("H2:H4")
  If Target.Address = "$C$5" Or Target.Address = "$C$2" Then
    删除图片
    ActiveSheet.Shapes.AddShape(msoShapeRectangle, Rg.Left, Rg.Top, Rg.Width, Rg.Height).Select
    Selection.ShapeRange.Fill.UserPicture ThisWorkbook.Path & "\图片\" & Cells(2, 3) & Cells(5, 3) & ".jpg"
  End If
  Set Rg = Nothing
End Sub

Private Sub CommandButton1_Click()
  On Error Resume Next
  Dim Arr(1 To 12), Brr, Shp As Shape
  Dim Dic
  Dim Rc%, K%
  Set Dic = CreateObject("scripting.dictionary")
  With Sheet1
   Arr(1) = .Cells(2, 3): Arr(2) = .Cells(2, 5): Arr(3) = .Cells(3, 5): Arr(4) = .Cells(4, 3)
   Arr(5) = .Cells(5, 3): Arr(7) = .Cells(4, 6): Arr(8) = .Cells(2, 7)
   Arr(9) = .Cells(3, 3): Arr(10) = .Cells(3, 7): Arr(11) = .Cells(5, 6): Arr(12) = .Cells(5, 8)
  End With
  For Each Shp In Sheet1.Shapes
    If Shp.Type <> 12 Then Shp.Copy
  Next Shp
  With Sheet2
    Rc = .Cells(Rows.Count, 2).End(xlUp).Row
    If Rc < 3 Then
      .Cells(3, 1) = 1
      .Cells(3, 2).Resize(1, 12) = Arr
      .ChartObjects.Add(.Range("G3").Left, .Range("G3").Top, .Range("G3").Width, .Range("G3").Height).Chart.Paste
    Else
      For K = 3 To Rc
        Dic(.Cells(K, 6).Text) = K
      Next K
      If Dic.Exists(Arr(5)) Then
        .Cells(Dic(Arr(5)), 2).Resize(1, 12) = Arr
      Else
        .Cells(Rc + 1, 1) = "=Counta($B$3:B" & Rc + 1 & ")"
        .Cells(Rc + 1, 2).Resize(1, 12) = Arr
        .ChartObjects.Add(.Cells(Rc + 1, 7).Left, .Cells(Rc + 1, 7).Top, .Cells(Rc + 1, 7).Width, .Cells(Rc + 1, 7).Height).Chart.Paste
      End If
    End If
  End With
End Sub


Sub 删除图片()
  Dim Shp As Shape
  For Each Shp In ActiveSheet.Shapes
    If Shp.Type <> 12 Then Shp.Delete
  Next Shp
End Sub


把图片存放在文件夹中，以姓名作为图片名称，格式为jpg格式，SHEET1中姓名发生变动时，自动填充图片。

徐海洋

hasyh2008 发表于 2022-5-9 22:32
Private Sub Worksheet_Change(ByVal Target As Range)
  On Error Resume Next
  Dim Rg As Range

谢谢您，尊师，照片这样做效果不好，如果有同名照片，怎么显示？删除行，序号不改变

徐海洋

hasyh2008 发表于 2022-5-9 22:32
Private Sub Worksheet_Change(ByVal Target As Range)
  On Error Resume Next
  Dim Rg As Range

谢谢老师，照片保存效果不好，删除行，序号不改变，

hasyh2008

徐海洋 发表于 2022-5-10 09:11
谢谢您，尊师，照片这样做效果不好，如果有同名照片，怎么显示？删除行，序号不改变:kis ...

可以用姓名+身份证命名图片，这样就不会重复了！！

徐海洋

hasyh2008 发表于 2022-5-10 09:45
可以用姓名+身份证命名图片，

hasyh2008

Private Sub Worksheet_Change(ByVal Target As Range)
  On Error Resume Next
  Dim Rg As Range
  Set Rg = Range("H2:H4")
  If Target.Address = "$C$5" Then
    删除图片
    ActiveSheet.Shapes.AddShape(msoShapeRectangle, Rg.Left, Rg.Top, Rg.Width, Rg.Height).Select
    Selection.ShapeRange.Fill.UserPicture ThisWorkbook.Path & "\图片\" & Cells(2, 3) & Cells(5, 3) & ".jpg"
  End If
  Set Rg = Nothing
End Sub
要先填写姓名，后填身份证号！

徐海洋

不

徐海洋

谢谢老师辛苦付出

hasyh2008

Private Sub Worksheet_Change(ByVal Target As Range)
  On Error Resume Next
  Dim Rg As Range
  Set Rg = Range("H2:H4")
  If Target.Address = "$C$5" Or Target.Address = "$C$2" Then
    删除图片
    ActiveSheet.Shapes.AddShape(msoShapeRectangle, Rg.Left, Rg.Top, Rg.Width, Rg.Height).Select
    Selection.ShapeRange.Fill.UserPicture ThisWorkbook.Path & "\图片\" & Cells(2, 3) & Cells(5, 3) & ".jpg"
  End If
  Set Rg = Nothing
End Sub

Private Sub CommandButton1_Click()
  On Error Resume Next
  Dim Arr(1 To 12), Brr, Shp As Shape
  Dim Dic
  Dim Rc%, K%
  Set Dic = CreateObject("scripting.dictionary")
  With Sheet1
   Arr(1) = .Cells(2, 3): Arr(2) = .Cells(2, 5): Arr(3) = .Cells(3, 5): Arr(4) = .Cells(4, 3)
   Arr(5) = .Cells(5, 3): Arr(7) = .Cells(4, 6): Arr(8) = .Cells(2, 7)
   Arr(9) = .Cells(3, 3): Arr(10) = .Cells(3, 7): Arr(11) = .Cells(5, 6): Arr(12) = .Cells(5, 8)
  End With
  For Each Shp In Sheet1.Shapes
    If Shp.Type <> 12 Then Shp.Copy
  Next Shp
  With Sheet2
    Rc = .Cells(Rows.Count, 2).End(xlUp).Row
    If Rc < 3 Then
      .Cells(3, 1) = 1
      .Cells(3, 2).Resize(1, 12) = Arr
      .ChartObjects.Add(.Range("G3").Left, .Range("G3").Top, .Range("G3").Width, .Range("G3").Height).Chart.Paste
    Else
      For K = 3 To Rc
        Dic(.Cells(K, 6).Text) = K
      Next K
      If Dic.Exists(Arr(5)) Then
        .Cells(Dic(Arr(5)), 2).Resize(1, 12) = Arr
      Else
        .Cells(Rc + 1, 1) = "=Counta($B$3:B" & Rc + 1 & ")"
        .Cells(Rc + 1, 2).Resize(1, 12) = Arr
        .ChartObjects.Add(.Cells(Rc + 1, 7).Left, .Cells(Rc + 1, 7).Top, .Cells(Rc + 1, 7).Width, .Cells(Rc + 1, 7).Height).Chart.Paste
      End If
    End If
  End With
End Sub


Sub 删除图片()
  Dim Shp As Shape
  For Each Shp In ActiveSheet.Shapes
    If Shp.Type <> 12 Then Shp.Delete
  Next Shp
End Sub

徐海洋

全好了，谢谢老师