因工作需要,要从同一文件夹下各个工作表的指定位置,取值,形成列表,并增加链接以便领导备查。
由于工作表都放在FTP共享上的,所以也将表格放在上一级的文件夹中
这些都是要取值的文件
这个就是要取值的内容,其中程序时间要转换成分钟
这个是最后的效果:
这里有两个按钮,一个是“仅新增”,一个是“全部刷新”。
仅新增是为了如果有新加的EXCEL时用来增加
全部刷新是如果有修改过的EXCEL覆盖了,全部更新掉
1、将转换分钟和拆分代码名称的FUNCTION分别写成两个模块
'将零件信息拆分成代码和名称
Function LJXXtoDMMC(ljxx As String) As Variant
Dim values(1 To 2) As Variant
values(1) = Mid(ljxx, 1, 14)
values(2) = Mid(ljxx, 15, Len(ljxx))
LJXXtoDMMC = values
End Function
''将程序时间换算成分钟
Function CxsjToNumber(cxsj As String) As Integer
Dim hou As Integer, minut As Integer, point As Integer
point = Application.WorksheetFunction.Search(":", CStr(cxsj), 1) '判断:的位置,用以分割时和分
hou = Mid(CStr(cxsj), 1, point - 1) * 60
minut = Mid(CStr(cxsj), point + 1, Len(CStr(cxsj)))
CxsjToNumber = hou + minut
End Function
2、仅新增的代码
Sub getaddfromfile()
Dim filepath As String, filename As String, thiswbname As String
Dim rowcount As Integer
Dim ws As Worksheet, targetws As Worksheet
Dim wb As Workbook
Dim ljxx As String, cxsj As String
Dim ljdmmc As Variant, gxh As Variant
Dim cxtime As Long
Dim fso As Object
Dim filecreatetime
Dim i As Long, j As Long, k As Long, l As Long
Application.ScreenUpdating = False '关闭屏幕更新,加快程序运行
Application.DisplayAlerts = False '不显示警告信息
thiswbname = ThisWorkbook.Name
Set targews = ThisWorkbook.Sheets("所有程序工时")
targews.Range("A1") = "零件代码"
targews.Range("B1") = "零件名称"
targews.Range("C1") = "程序时间"
targews.Range("D1") = "工序号"
targews.Range("E1") = "变更时间"
targews.Range("F1") = "链接"
filepath = ThisWorkbook.Path & "\程序工时\"
filename = Dir(filepath & "*.xls")
Set fso = CreateObject("Scripting.FileSystemObject")
k = 0
Do While filename <> "" '判断文件名不为空时
If filename <> thiswbname Then '判断是不是当前文件
rowcount = Cells(targews.Rows.Count, 1).End(xlUp).Row '获取目标表最新行数
ljdmmc = toDMMC.LJXXtoDMMC(filename) '获取文件名上的零件代码,因为都习惯将代码放在前面,所以可以共用这个FUNCTION
filecreatetime = fso.GetFile(filepath & filename).DateCreated '获取文件时间
''用于判断文件名中的代码是否在列表中存在,不存在则新增
With targews
j = 0
''当有同一零件存在多个文件时
Dim ARR()
Dim ljdm As Variant
''将表中数据装入数组
ReDim ARR(1 To rowcount, 1 To 3)
i = 0
For i = 1 To rowcount
ARR(i, 1) = Cells(i, 1) '零件代码
ARR(i, 2) = Cells(i, 6) '链接
ARR(i, 3) = Cells(i, 5) '变更时间
Cells(i, 5).Font.Color = RGB(0, 0, 0) '顺便将变更时间还原成黑色
Next i
''文件信息与数组中的内容进行比对
i = 0
j = 0
l = 0
For i = 1 To UBound(ARR) '遍历数组
If ARR(i, 1) = ljdmmc(1) And ARR(i, 2) = filename Then
j = 1 '表示有重复
''''当有重复时,判断文件日期是否相同,如果不同,则将“变更时间”字体颜色变成红色,表示有变更
If ARR(i, 3) <> CDate(Format(filecreatetime, "YYYY/MM/DD")) Then
.Cells(i, 5).Value = Format(filecreatetime, "YYYY/MM/DD")
.Cells(i, 5).Font.Color = RGB(255, 0, 0)
l = l + 1
End If
End If
Next
If j <> 1 Then '当不重复时
Set wb = Workbooks.Open(filepath & filename) '打开文件
ljxx = wb.Sheets(1).Range("E4").Value '零件信息
cxsj = Format(wb.Sheets(1).Range("N15").Value, "hh:mm") '程序时间,保证格式为hh:mm
gxh = wb.Sheets(1).Range("D3").Value '工序号
wb.Close SaveChanges:=False '关闭文件并不保存
'将记录都增加在最后一行的下一行
ljdmmc = toDMMC.LJXXtoDMMC(ljxx) '零件信息拆分
.Cells(rowcount, 1).Offset(1, 0).Value = ljdmmc(1)
.Cells(rowcount, 1).Offset(1, 1).Value = ljdmmc(2)
cxtime = toMinute.CxsjToNumber(cxsj) '换算程序时间
.Cells(rowcount, 1).Offset(1, 2).Value = cxtime
.Cells(rowcount, 1).Offset(1, 3).Value = "'" & gxh
.Cells(rowcount, 1).Offset(1, 4).Value = Format(filecreatetime, "YYYY/MM/DD")
.Cells(rowcount, 1).Offset(1, 5).Value = filename
ActiveSheet.Hyperlinks.Add Anchor:=.Cells(rowcount, 1).Offset(1, 5), Address:=filepath & filename, SubAddress:="", ScreenTip:="", TextToDisplay:=filename
k = k + 1
End If
End With
filename = Dir() ' 获取下一个文件名
End If
Loop
MsgBox "共新增了 " & k & " 行;并且有" & l & "项有日期变更"
Set fso = Nothing
moformat.moformat '设置格式
'''''''''''''''''''''''''''''''''''''''''
''''''''标出重复值
rowcount = Cells(targews.Rows.Count, 1).End(xlUp).Row '获取目标表最新行数
For i = 2 To rowcount
If Application.CountIf(Range("a1:a" & rowcount), Cells(i, 1)) > 1 Then
Cells(i, 1).Font.Color = RGB(255, 0, 0) ' 红色字体
Cells(i, 1).Interior.Color = RGB(255, 204, 204) ' 浅红色背景
End If
Next i
'''''''''''''''''''''''''''''''''''''''''
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
3、全部刷新的代码
Sub getcallfromfile()
Dim filepath As String, filename As String, thiswbname As String
Dim rowcount As Integer
Dim ws As Worksheet, targetws As Worksheet
Dim wb As Workbook
Dim ljxx As String, cxsj As String
Dim ljdmmc As Variant, gxh As Variant
Dim cxtime As Long
Dim fso As Object
Dim filecreatetime
Application.ScreenUpdating = False '关闭屏幕更新,加快程序运行
Application.DisplayAlerts = False '不显示警告信息
thiswbname = ThisWorkbook.Name
Set targews = ThisWorkbook.Sheets("所有程序工时")
'''刷新前先清除全部数据
targews.Cells(1, 1).CurrentRegion.Clear
targews.Range("A1") = "零件代码"
targews.Range("B1") = "零件名称"
targews.Range("C1") = "程序时间"
targews.Range("D1") = "工序号"
targews.Range("E1") = "变更时间"
targews.Range("F1") = "链接"
filepath = ThisWorkbook.Path & "\程序工时\"
filename = Dir(filepath & "*.xls")
Set fso = CreateObject("Scripting.FileSystemObject")
Do While filename <> "" '判断文件名不为空时
If filename <> thiswbname Then '判断不是当前文件
Set wb = Workbooks.Open(filepath & filename) '打开文件
ljxx = wb.Sheets(1).Range("E4").Value '零件信息
cxsj = Format(wb.Sheets(1).Range("N15").Value, "hh:mm") '程序时间,保证格式为hh:mm
gxh = wb.Sheets(1).Range("D3").Value '工序号
filecreatetime = fso.GetFile(filepath & filename).DateCreated '获取文件时间
wb.Close SaveChanges:=False '关闭文件并不保存
End If
rowcount = Cells(targews.Rows.Count, 1).End(xlUp).Row '获取目标表最新行数
ReDim timearr(1 To rowcount, 1 To 2)
ljdmmc = toDMMC.LJXXtoDMMC(ljxx) '零件信息拆分
Cells(rowcount, 1).Offset(1, 0).Value = ljdmmc(1)
Cells(rowcount, 1).Offset(1, 1).Value = ljdmmc(2)
cxtime = CxsjToNumber(cxsj) '换算程序时间
Cells(rowcount, 1).Offset(1, 2).Value = cxtime
Cells(rowcount, 1).Offset(1, 3).Value = "'" & gxh
Cells(rowcount, 1).Offset(1, 4).Value = Format(filecreatetime, "YYYY/MM/DD")
Cells(rowcount, 1).Offset(1, 5).Value = filename
ActiveSheet.Hyperlinks.Add Anchor:=Cells(rowcount, 1).Offset(1, 5), Address:=filepath & filename, SubAddress:="", ScreenTip:="", TextToDisplay:=filename
filename = Dir() ' 获取下一个文件名
Loop
Set fso = Nothing
moformat.moformat '设置格式
''''''''标出重复值
rowcount = Cells(targews.Rows.Count, 1).End(xlUp).Row '获取目标表最新行数
For i = 2 To rowcount
If Application.CountIf(Range("a1:a" & rowcount), Cells(i, 1)) > 1 Then
Cells(i, 1).Font.Color = RGB(255, 0, 0) ' 红色字体
Cells(i, 1).Interior.Color = RGB(255, 204, 204) ' 浅红色背景
End If
Next i
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub