能否帮忙看下如何提取无发票合同的数据

dagal

求助，当每个表内的H,I列无发票或无合同的数据给提出出来汇总到一张表上，如果发票与合同都有的就不需要提取。谢谢了~

预付款(1).rar (14.57 KB, 下载次数: 14)

2024-7-24 12:56 上传

点击文件名下载附件

ykcbf1100

参与一下。。。

ykcbf1100

参与一下。。。

1. Sub ykcbf()    '//2024.7.24
   
2.     Application.ScreenUpdating = False
   
3.     Set sh = ThisWorkbook.Sheets("汇总")
   
4.     ReDim brr(1 To 10000, 1 To 100)
   
5.     For Each sht In Sheets
   
6.         If sht.Name <> sh.Name Then
   
7.             arr = sht.UsedRange
   
8.             For i = 2 To UBound(arr)
   
9.                 If arr(i, 1) <> Empty Then
   
10.                     If Trim(arr(i, 8)) & Trim(arr(i, 9)) <> "有有" Then
    
11.                         m = m + 1
    
12.                         brr(m, 1) = m
    
13.                         For j = 2 To UBound(arr, 2)
    
14.                             brr(m, j) = arr(i, j)
    
15.                         Next
    
16.                     End If
    
17.                 End If
    
18.             Next
    
19.         End If
    
20.     Next
    
21.     With sh
    
22.         .UsedRange.Offset(1).ClearContents
    
23.         .[a2].Resize(m, 9) = brr
    
24.         .[a2].Resize(m, 9).Borders.LineStyle = 1
    
25.     End With
    
26.     Application.ScreenUpdating = True
    
27.     MsgBox "OK！"
    
28. End Sub
    

复制代码

lsc900707

参考测试附件：

Qs18

Sub qs()
Application.DisplayAlerts = False
Dim sht As Worksheet, arr, st As Worksheet
ReDim brr(1 To 10000, 1 To 9)
For Each sht In Sheets
    If sht.Name = "汇总表" Then
    sht.Delete
    End If
Next
For Each sht In Sheets
    arr = sht.Range("a1").CurrentRegion.Value
    For i = 2 To UBound(arr)
        s = arr(i, 8) & arr(i, 9)
        If s <> "有有" Then
            m = m + 1
            For j = 1 To 9
                brr(m, j) = arr(i, j)
            
            Next
        End If
    Next
Next
     Set st = Sheets.Add
     st.Name = "汇总表"
     st.Range("a1").Resize(1, 9) = Application.Index(arr, 1, 0)
     st.Range("a2").Resize(m, 9) = brr
With st.Range("a1").CurrentRegion
       .Borders.LineStyle = 1
End With
Application.DisplayAlerts = True
End Sub

Qs18

试试..........

Qs18

试试..........

awen7878

参与学习一下

usedrange

1. Sub t()
   
2.     Dim sh, wb, f, box, r%, i%
   
3.     Set sh = Sheets.Add
   
4.     sh.Name = "汇总"
   
5.     Sheet1.[a1].Resize(1, 9).Copy sh.[a1].Resize(1, 9)
   
6.     sh.[a1].Resize(1, 9).Columns.AutoFit
   
7.     r = 2
   
8.     For Each f In Sheets
   
9.         Set wb = Sheets(f.Name).UsedRange
   
10.         For i = 1 To UBound(wb.Value)
    
11.             If (wb(i, 8) = "" Or wb(i, 9) = "") And wb(i, 2) <> "" Then
    
12.                 Set box = wb(i, 1).Resize(1, 9)
    
13.                 Sheets(sh.Name).Cells(r, 1).Resize(1, 9) = box.Value
    
14.                 r = r + 1
    
15.             End If
    
16.         Next i
    
17.         Set wb = Nothing
    
18.         Set box = Nothing
    
19.     Next f
    
20.     Set sh = Nothing
    
21. End Sub

复制代码