VBA自动提取E列涂颜色的单元格对应的C列的日期

luketools

因为要统计客户每月应收款，所以希望可以自动抓取未付款的发票最早的月份，即<苏州>工作表中E列第一个涂颜色的单元格对应的日期，其他客户以此类推.

在客户明细表中E列未付款的发票金额都会用涂颜色表示，付款后会把颜色手动取消，
苏州客户未付款的发票最早的是472.34，这张发票的日期是2019/11/14，所以销售总表中F3显示2019/11/14。

上海客户F4显示：2019/2/28

浙江客户因为全部已付款，销售总表中F5显示"---"即可。表示没有应付款的发票。

因为有很多客户，因为有很多客户，希望当增加客户时工作表名称和B列客户名称相同时，后面对应的F列自动添加日期。本来想用函数公式的，但是好像函数不能实现（如果函数可以实现的话用函数公式也可以），所以求助VBA大神。

Jaofuan

1. Sub jaofuan()
   
2.     Dim arr
   
3.     arr = Sheet1.Range("A1").CurrentRegion.Offset(2)
   
4.     For i = 1 To UBound(arr)
   
5.         If arr(i, 2) <> "" Then
   
6.             r = Sheets(arr(i, 2)).Cells(65536, 5).End(xlUp).Row - 1
   
7.             For x = 9 To r
   
8.                 If Sheets(arr(i, 2)).Cells(x, "E").Interior.ColorIndex > 0 Then
   
9.                     arr(i, 6) = Sheets(arr(i, 2)).Cells(x, "C")
   
10.                     Exit For
    
11.                 End If
    
12.             Next
    
13.             If arr(i, 6) = "" Then arr(i, 6) = "---"
    
14.         End If
    
15.     Next
    
16.     Sheet1.Range("A3").Resize(UBound(arr), UBound(arr, 2)) = arr
    
17. End Sub

复制代码

luketools

Jaofuan 发表于 2021-3-8 12:06

谢谢你的代码，不过我表格增加了一点东西，代码运行显示下限超标，烦请在帮忙修改一下，谢谢！就是在B列客户名称表格的最下面增加了一些总计及注释，是不是因为检索B列内容时后面没有这个名称的工作表造成的，这个代码应该怎么改？

luketools

Jaofuan 发表于 2021-3-8 12:06

重新上传了附件，一开始的附件表格不全，抱歉。请帮忙修改一下代码，谢谢！

Jaofuan

luketools 发表于 2021-3-8 13:21
重新上传了附件，一开始的附件表格不全，抱歉。请帮忙修改一下代码，谢谢！

因为你的客户名称和工作表名称不匹配，

1. Sub jaofuan()
   
2.     Dim arr
   
3.     On Error Resume Next
   
4.     arr = Sheet1.Range("A1").CurrentRegion.Offset(2)
   
5.     For i = 1 To UBound(arr)
   
6.         If arr(i, 2) <> "" And arr(i, 2) <> "总计：" Then
   
7.             r = Sheets(arr(i, 2)).Cells(65536, 5).End(xlUp).Row - 1
   
8.             For x = 9 To r
   
9.                 If Sheets(arr(i, 2)).Cells(x, "E").Interior.ColorIndex > 0 Then
   
10.                     arr(i, 6) = Sheets(arr(i, 2)).Cells(x, "C")
    
11.                     Exit For
    
12.                 End If
    
13.             Next
    
14.             If arr(i, 6) = "" Then arr(i, 6) = "---"
    
15.         End If
    
16.     Next
    
17.     Sheet1.Range("A3").Resize(UBound(arr), UBound(arr, 2)) = arr
    
18. End Sub

复制代码

luketools

Jaofuan 发表于 2021-3-8 12:06

你好，我前面遇到的问题我已经解决了，现在又遇到一个问题，销售总表中的C,D,E 列是用函数公式统计的数据，为什么执行代码后这3列的公式都没有了，只保留了数据，没有了公式后当后面明细表中的数据变化时，总表中的数据就不能变化了，请问这个怎么解决？谢谢！
我希望只是在F列填入日期，其他单元格的数据及公式不受影响。

Jaofuan

luketools 发表于 2021-3-9 17:47
你好，我前面遇到的问题我已经解决了，现在又遇到一个问题，销售总表中的C,D,E 列是用函数公式统计的数据 ...

那就建立两个数组，把匹配的数据放进另一个数组

luketools

Jaofuan 发表于 2021-3-10 08:19
那就建立两个数组，把匹配的数据放进另一个数组

这个我不太会，可否麻烦您帮忙把代码修改一下，谢谢！
先送朵小花以示感谢。

Jaofuan

1. Sub jaofuan()
   
2.     Dim arr, br, drow As Long, r As Long
   
3.     On Error Resume Next
   
4.     drow = Sheet1.Cells(65536, 3).End(xlUp).Row
   
5.     Sheet1.Range("F3:F" & drow) = ""
   
6.     arr = Sheet1.Range("B3:B" & drow)
   
7.     ReDim br(1 To UBound(arr))
   
8.     For i = 1 To UBound(arr)
   
9.         If arr(i, 1) <> "" And arr(i, 1) <> "总计：" Then
   
10.             r = Sheets(arr(i, 1)).Cells(65536, 5).End(xlUp).Row - 1
    
11.             For x = 9 To r
    
12.                 If Sheets(arr(i, 1)).Cells(x, "E").Interior.ColorIndex > 0 Then
    
13.                     br(i) = Sheets(arr(i, 1)).Cells(x, "C")
    
14.                     Exit For
    
15.                 End If
    
16.             Next
    
17.             If br(i) = "" Then br(i) = "---"
    
18.         End If
    
19.     Next
    
20.     Sheet1.Range("F3").Resize(UBound(br), 1) = Application.Transpose(br)
    
21. End Sub

复制代码

Jaofuan