VBA 从同一文件夹下各个工作表的相同位置取值，形成表单并增加链接

因工作需要，要从同一文件夹下各个工作表的指定位置，取值，形成列表，并增加链接以便领导备查。

由于工作表都放在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