VBA 根据A文件夹的数据取B找到对应的数据返写A里的表

VBA 根据A文件夹的数据取B找到对应的数据返写A里的表

Sub 处理即将到期数据()

Dim sourceWorkbook As Workbook
Dim newPath As String
Dim newFileName As String

'复制新表到指定的路径
Dim pathA As String
Dim pathB As String
Dim pathC As String

Dim fso As Object
 ' 创建FileSystemObject实例
Set fso = CreateObject("Scripting.FileSystemObject")


pathA = ThisWorkbook.Path & "\A\"
pathA = ThisWorkbook.Path & "\A\" & Dir(pathA) '获取原始表的文件夹里面的表

pathB = ThisWorkbook.Path & "\B\"
pathB = ThisWorkbook.Path & "\B\" & Dir(pathB)



newPath = ThisWorkbook.Path & "\完成数据表\"
newFileName = "处理完成的表.xlsx"
pathC = newPath & newFileName

' 确保路径存在
    If Not fso.FolderExists(newPath) Then
        MsgBox "指定的路径不存在！", vbExclamation
        Exit Sub
    End If
 ' 复制文件
    FileCopy pathA, pathC
    
    ' 清理
    Set sourceWorkbook = Nothing
    Set fso = Nothing
    
'打开新的文件
Dim wba As Workbook
Dim wsa As Worksheet

Set wba = Workbooks.Open(pathC)
Set wsa = wba.Worksheets("Sheet1")

Dim keysArray() As Variant
Dim itemsArray() As Variant
'创建一个字典
Dim dict1 As Object
Set dict1 = CreateObject("Scripting.Dictionary")
dict1.RemoveAll

Dim myArray() As Variant
lastRow = wsa.Cells(wsa.Rows.Count, "A").End(xlUp).Row
lastColumn = wsa.Cells(1, wsa.Columns.Count).End(xlToLeft).Column
' 将数据复制到数组
myArray = wsa.Range(wsa.Cells(1, 1), wsa.Cells(lastRow, lastColumn)).Value
 For i = 2 To lastRow
    If Trim(wsa.Cells(i, 20)) = "Supply" And wsa.Cells(i + 1, 75) < 0 Then
    'MsgBox 22
        If dict1.Exists(Trim(wsa.Cells(i, 5))) Then
            hang = dict1(Trim(wsa.Cells(i, 5)))
            If wsa.Cells(i + 1, 75) < wsa.Cells(hang + 1, 75) Then
                 dict1(Trim(wsa.Cells(i, 5))) = i
            End If
            
        Else
            dict1.Add Trim(wsa.Cells(i, 5)), i
            
        End If
    End If
 
 Next i
 
 ' 将物料名放入数组
keysArray = dict1.Keys
 
' 将行号放入数组
itemsArray = dict1.Items

dict1.RemoveAll
Dim wbb As Workbook
Dim wsb As Worksheet
Dim strname As String
Dim wordsl As String
Dim sgdate As Date
Dim awdate As Date
Dim awdate2 As Date

Set wbb = Workbooks.Open(pathB)
Set wsb = wbb.Worksheets(1)
lastRowb = wsb.Cells(wsb.Rows.Count, "A").End(xlUp).Row
lastColumnb = wsb.Cells(1, wsb.Columns.Count).End(xlToLeft).Column

For i = 2 To lastRowb
If wsb.Cells(i, 37) <> "" Then
    wordsl = "联宝"
    strname = Trim(wsb.Cells(i, 37))
    bjitem = Trim(wsb.Cells(i, 8))
     If ContainsWord(strname, wordsl) Then
     xiestate = 0
         For j = 0 To UBound(keysArray)
         If xiestate = 1 Then
         Exit For
         End If
            If bjitem = keysArray(j) Then
                '找到生管交期23列
                'sgdate = Trim(wsb.Cells(i, 23))
                If Trim(wsb.Cells(i, 23)) <> "" Then
                sgdate = GetDateAfter14Days(Trim(wsb.Cells(i, 23)))
                Else
                sgdate = GetDateAfter14Days(Trim(wsb.Cells(i - 1, 23)))
                End If
                '匹配周数据
                For m = 23 To lastColumn '周计算是从23列第一行算
                    strname1 = Trim(wsa.Cells(1, m))
                    strname2 = Trim(wsa.Cells(1, m + 1))
                    If strname1 <> "" And strname2 <> "" Then
                        result = Split(strname1, "(")
                        result1 = Split(strname2, "(")
                        If result(1) <> "" And result1(1) <> "" Then
                                re1 = Split(result(1), ")")
                                re2 = Split(result1(1), ")")
                                If re1(0) <> "" And re2(0) <> "" Then
                                     awdate = re1(0)
                                     awdate2 = re2(0)
                                     
                                     If sgdate >= awdate And sgdate < awdate2 Then
                                        arow = itemsArray(j)
                                        wsa.Cells(arow, m) = CDbl(wsa.Cells(arow, m)) + CDbl(wsb.Cells(i, 9)) '填写数量
                                        wsa.Cells(arow, m).Interior.Color = RGB(255, 255, 0) ' 黄色
                                        xiestate = 1
                                        Exit For
                                    Else
                                    'Exit For
                                    End If
                                End If
                        End If
                    End If
                Next m
                
                
            End If
         Next j
     End If
End If
Next i
MsgBox "处理完成！"
End Sub
Function GetDateAfter14Days(inputDate As Date) As Date
    ' 使用DateAdd函数计算给定日期后的14天日期
    GetDateAfter14Days = DateAdd("d", 14, inputDate)
End Function

Function ContainsWord(str As String, word As String) As Boolean
    ContainsWord = InStr(1, str, word, vbTextCompare) > 0
End Function