求助VBA解决数据问题

yufei6699

最近由于处理数据太多，需要大量时间，希望能用VBA实现，恳请论坛的老师请教！
主要有两个问题：
1.表格案卷目录里面，我标红的部分，B列（馆编档号）和N列（卷内文件份数），我想要B列的单元格对应的复制N列数字的份数（比如B2复制66份，B3复制322份），依次填入卷内目录表格中的C列

2.卷内目录中H列（页数）的数字，其实就是P列页号后面一个数字减去前面一个数字的差，但是会遇到几种情况，单纯的减会有问题，第一个：比如P列中65行和66行数字是一样的，减一下就是O了，正确的应该是要填1，第二个P列66行是67行前三个数字减上面一个数字，第三个：比如每一卷最后一个数字表示的是XXX-XXX（P列67行），页数就是两个数字减一下再加1

lcluck2002

第一个问题，本身没问题，但请问一下，只顾C列，卷内目录这个表的其他列是什么不用管吗？
第二个问题，没看明白。因为不明白P列的数据是啥子意思。

yufei6699

lcluck2002 发表于 2022-11-16 14:45
第一个问题，本身没问题，但请问一下，只顾C列，卷内目录这个表的其他列是什么不用管吗？
第二个问题，没 ...

关于第一个问题，卷内目录这个表格其他列不用管，其他列填的数据情况比较简单，我拉一下就可以解决。
关于第二个问题，P列数据就是页号，第一条P1是第1页，第二条P2是第3页，也就是第一条的内容总共有2页。打个比方就是一本书的第几页，每一个内容对应的是第几页，我想实现每一条内容对应总共有几页。因为这些数据要导入系统，有位数要求，都是001开始编。

shiruiqiang

好像和这个差不多

Sub text()
Dim arr, brr, i, j, n
arr = Sheets(1).[a1].CurrentRegion
ReDim brr(1 To Application.Sum(Sheets(1).Range("n:n")), 1 To 1)
    For i = 2 To UBound(arr)
        For j = 2 To arr(i, 14)
            n = n + 1
            brr(n, 1) = arr(i, 2)
        Next
    Next
    Sheets(2).[c2].Resize(UBound(brr), 1) = brr
End Sub

shiruiqiang

第一个问题等审核。第二个问题还没理解.是否（x,3）=(x+1,3),(x,8)=(x+1,16)-(x,16)其中判断=0的话修改为1

yufei6699

shiruiqiang 发表于 2022-11-16 18:00
好像和这个差不多

Sub text()

这个运行出来有点不一样，每卷少一个，我自己手工复制了一份

徐文祝

这两天没空，你得等等。

徐文祝

1. Sub Contents()
   
2. '*******************by大独裁家*******************
   
3.     Application.ScreenUpdating = False
   
4.     Dim i, j, k, arr, brr, crr, x, y
   
5. '    Dim conn As New ADODB.Connection '连接对象
   
6. '    Dim rst As New ADODB.Recordset '记录集
   
7.     Dim conn As Object, rst As Object
   
8.     Set conn = CreateObject("ADODB.Connection")
   
9.     Set rst = CreateObject("ADODB.Recordset")
   
10.     Dim mypath, sql
    
11.     mypath = ThisWorkbook.FullName
    
12.     conn.Open "provider=Microsoft.ACE.OLEDB.12.0; extended properties=excel 12.0; data source=" & mypath
    
13.     sql = "SELECT 馆编档号, 卷内文件份数 from [案卷目录$]"
    
14.     rst.Open sql, conn, 3, 2  '执行sql语句，获得记录集
    
15.     arr = rst.GetRows '得到一个结果数组，行列转置，下标为0
    
16.     Sheets("卷内目录").Cells(2, "C").Resize(1048575).ClearContents
    
17.     Sheets("卷内目录").Cells(2, "H").Resize(1048575).ClearContents
    
18.     k = 2
    
19.     For i = 0 To UBound(arr, 2)
    
20.         If arr(1, i) <> "" Then
    
21.             Sheets("卷内目录").Cells(k, "C").Resize(arr(1, i)) = arr(0, i)
    
22.             k = k + arr(1, i)
    
23.         End If
    
24.     Next
    
25.     brr = Sheets("卷内目录").Cells(1, 1).CurrentRegion
    
26.     For i = 2 To UBound(brr)
    
27. '        If i = 67 Then Stop
    
28.         If brr(i, 16) Like "*-*" Then
    
29.             crr = Split(brr(i, 16), "-")
    
30.             brr(i, 8) = crr(1) - crr(0)
    
31.         ElseIf brr(i + 1, 16) Like "*-*" Then
    
32.             crr = Split(brr(i + 1, 16), "-")
    
33.             brr(i, 8) = crr(0) - brr(i, 16)
    
34.         Else
    
35.             brr(i, 8) = brr(i + 1, 16) - brr(i, 16)
    
36.         End If
    
37.         If brr(i, 8) = 0 Then brr(i, 8) = 1
    
38.     Next
    
39.     ReDim crr(2 To UBound(brr), 1 To 1)
    
40.     For i = 2 To UBound(brr)
    
41.         crr(i, 1) = brr(i, 8)
    
42.     Next
    
43.     Sheets("卷内目录").Cells(2, "H").Resize(UBound(crr) - 1) = crr
    
44.     Application.ScreenUpdating = True
    
45. End Sub

复制代码

yufei6699

徐文祝 发表于 2022-11-19 13:04

谢谢徐老师