Excel精英培训网

 找回密码
 注册
数据透视表40+个常用小技巧,让你一次学会!
查看: 2149|回复: 21

[已解决]简历保存

[复制链接]
发表于 2022-5-7 17:55 | 显示全部楼层 |阅读模式
2学分
本帖最后由 徐海洋 于 2022-5-7 17:59 编辑

图1.png
表1
图2.png
表2


请老师指教,输入身份证号相同,覆盖不增加,输入身份证号不同,新增记录,谢谢


[url=]简历保存.zip[/url]


最佳答案
2022-5-7 17:55
本帖最后由 hasyh2008 于 2022-5-18 08:11 编辑

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

简历保存.zip

110.69 KB, 下载次数: 10

最佳答案

查看完整内容

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) & ".j ...
发表于 2022-5-7 17:55 | 显示全部楼层    本楼为最佳答案   
本帖最后由 hasyh2008 于 2022-5-18 08:11 编辑

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

简历保存(20220508).rar

47.05 KB, 下载次数: 3

回复

使用道具 举报

发表于 2022-5-7 22:14 | 显示全部楼层
Sub a()
    If InStr(Join(Application.Transpose(Sheet2.Range("E3:E" & Sheet2.Range("E65536").End(xlUp).Row))), Cells(4, 3)) > 0 Then
        MsgBox "重复数据,请重新录入"
        Exit Sub
    Else
        Sheet2.Range("B" & Sheet2.Range("B65536").End(xlUp).Row + 1).Resize(1, 12) = _
        Array(Range("C2"), Range("E2"), Range("E3"), Range("C4"), Range("C5"), Range("H2"), Range("F4"), Range("G2"), Range("C3"), Range("G3"), Range("F5"), Range("H5"))
    End If
    MsgBox "保存完毕"
End Sub

简历保存.zip

115.81 KB, 下载次数: 8

回复

使用道具 举报

发表于 2022-5-7 23:31 | 显示全部楼层
limonet 发表于 2022-5-7 22:14
Sub a()
    If InStr(Join(Application.Transpose(Sheet2.Range("E3:E" & Sheet2.Range("E65536").End(xl ...

老师  这种公式怎么写呢   vba A&n 大于x A&M小于y,"",A&n
回复

使用道具 举报

 楼主| 发表于 2022-5-8 00:06 | 显示全部楼层
本帖最后由 徐海洋 于 2022-5-8 00:08 编辑
limonet 发表于 2022-5-7 22:14
Sub a()
    If InStr(Join(Application.Transpose(Sheet2.Range("E3:E" & Sheet2.Range("E65536").End(xl ...

图3.png
谢谢,照片保存不了,我要手机号相同,其它覆盖保存,手机号不同,另存数据,手机号列不能重复

回复

使用道具 举报

发表于 2022-5-8 20:04 | 显示全部楼层
徐海洋 发表于 2022-5-8 00:06
谢谢,照片保存不了,我要手机号相同,其它覆盖保存,手机号不同,另存数据,手机号列不能重复

你的附件就没有图。
微信截图_20220508200336.png
回复

使用道具 举报

发表于 2022-5-8 23:29 | 显示全部楼层
本帖最后由 hasyh2008 于 2022-5-8 23:43 编辑

不知道你图片是如何添加的,所以只在表二中复制了表一H2中的公式。是身份证号不重复吧?
Private Sub CommandButton1_Click()
  Dim Arr(1 To 12), Brr
  Dim Pic As Shape
  Dim Dic
  Dim Rng As Range
  Dim Rc%, K%
  Set Dic = CreateObject("scripting.dictionary")
  On Error Resume Next
  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

  With Sheet2
    Brr = .Cells(1, 1).CurrentRegion
    Rc = UBound(Brr)
    If Rc < 3 Then
      .Cells(3, 2).Resize(1, 12) = Arr
      .Cells(3, 7) = Sheet1.Range("H2").Formula
      Exit Sub
    Else
      For K = 3 To Rc
        Dic(Brr(K, 6)) = K
      Next K
      If Dic.Exists(Arr(5)) Then
        .Cells(Dic(Arr(5)), 2).Resize(1, 12) = Arr
        .Cells(Dic(Arr(5)), 7) = Sheet1.Range("H2").Formula
      Else
        .Cells(Rc + 1, 2).Resize(1, 12) = Arr
        .Cells(Rc + 1, 7) = Sheet1.Range("H2").Formula
      End If
    End If
  End With
End Sub

简历保存(20220508).rar

23.54 KB, 下载次数: 3

回复

使用道具 举报

 楼主| 发表于 2022-5-9 17:25 | 显示全部楼层
本帖最后由 徐海洋 于 2022-5-9 17:31 编辑
hasyh2008 发表于 2022-5-8 23:29
不知道你图片是如何添加的,所以只在表二中复制了表一H2中的公式。是身份证号不重复吧?
Private Sub Comm ...

非常谢谢老师,辛苦了,要是能用我的代码修改就好了,Arr(1) = .Cells(2, 3)是什么意思?没看懂,表还有很多内容,不知怎么加上去,每一句能注释就好了,希老师指点赐教
还有,我用WPS能保存照片,excel不行,照片格怎样才能保存照片呢???

简历保存 (1).zip (115.81 KB, 下载次数: 3)
回复

使用道具 举报

发表于 2022-5-9 18:35 | 显示全部楼层
徐海洋 发表于 2022-5-9 17:25
非常谢谢老师,辛苦了,要是能用我的代码修改就好了,Arr(1) = .Cells(2, 3)是什么意思?没看懂,表还有 ...

因为表2中要填写12个信息,所以设置数组Arr(1 to 12),Arr(1) = .Cells(2, 3)表示数组的第一个元素等于Sheet1的第二行第三列,也就是C2的值。在EXCEL中好像光用函数不能添加图片,还要做相应的设置。其实用VBA添加图片效果更好!!
回复

使用道具 举报

 楼主| 发表于 2022-5-9 19:27 | 显示全部楼层
本帖最后由 徐海洋 于 2022-5-9 20:04 编辑
hasyh2008 发表于 2022-5-9 18:35
因为表2中要填写12个信息,所以设置数组Arr(1 to 12),Arr(1) = .Cells(2, 3)表示数组的第一个元素等于She ...

谢谢老师大爱,我已将代码修改好,就是照片无法嵌入保存,我原来代码您能帮修改吗?可以留下您的联系方式吗?多向您请教指点,

还有,第一列是公式序号,=IF(LEN(D3)=0,"",SUBTOTAL(3,D$3:D3))  ,你这代码不能在第一列后填充保留数据,我那代码能行,请老师赐教
回复

使用道具 举报

您需要登录后才可以回帖 登录 | 注册

本版积分规则

小黑屋|手机版|Archiver|Excel精英培训 ( 豫ICP备11015029号 )

GMT+8, 2024-3-29 16:34 , Processed in 0.701341 second(s), 10 queries , Gzip On, Yac On.

Powered by Discuz! X3.4

Copyright © 2001-2020, Tencent Cloud.

快速回复 返回顶部 返回列表