条件提取数据在同一工作表内。

hbszls

按指定的条件顺序提取数据生成设定样式的工作表，方便连续打印。恳请各位帮忙，谢谢！

蓝桥玄霜

测试的例子：

joy.008@163.com

1. Sub joy008()
   
2. 
   
3. Dim arr, d, ds, i%, S$, r%
   
4. 
   
5. Set d = CreateObject("Scripting.Dictionary")
   
6. Set ds = CreateObject("Scripting.Dictionary")
   
7. arr = Sheet1.Range("A1").CurrentRegion
   
8. For i = 2 To UBound(arr)
   
9.     S = arr(i, 2)
   
10.     If d.Exists(S) Then
    
11.         d(S) = d(S) & "," & arr(i, 3)
    
12.     Else
    
13.         d(S) = arr(i, 3)
    
14.     End If
    
15. Next
    
16. arr = Sheet4.Range("A1").CurrentRegion
    
17. For i = 2 To UBound(arr)
    
18.     S = arr(i, 1)
    
19.     ds(S) = arr(i, 2)
    
20. Next
    
21. Sheet5.Activate
    
22. For Each k In d.keys
    
23.     arr = Split(d(k), ",")
    
24.     r = r + 1
    
25.     Sheet2.Range("A1:R4").Copy Cells(r, 1)
    
26.     Cells(r + 1, 3) = k: Cells(r + 1, 14) = ds(k)
    
27.     r = r + 3: r1 = 0
    
28.     For i = 0 To UBound(arr)
    
29.         r = r + 1: Cells(r, 2) = arr(i)
    
30.         r1 = r1 + 1: Cells(r, 1) = r1
    
31.     Next
    
32.     Sheet5.Rows(r + 1).PageBreak = xlPageBreakManual
    
33. Next
    
34. 
    
35. End Sub
    

复制代码

joy.008@163.com

joy.008@163.com

测试无误~~~

limonet

Sub limonet()
    Dim Cn As Object, StrSQL$, Arr As Variant, i%, Rst As Object, Rng As Range
    Set Cn = CreateObject("Adodb.Connection")
    Cn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties=Excel 12.0;Data Source=" & ThisWorkbook.FullName
    Set Rst = Cn.Execute("Select 姓名,班级    From [名单$B:C]")
    Do Until Rst.EOF
        i = Range("A" & Rows.Count).End(xlUp).Row + 1
        Arr = Rst.GetRows(11)
        Sheet2.Range("A1").CurrentRegion.Copy Cells(i + 1, "A")
        ActiveSheet.PageSetup.PrintArea = Mid(ActiveSheet.PageSetup.PrintArea & "," & Cells(i + 1, "A").CurrentRegion.Address(), 2)
        Cells(i + 2, "C") = Arr(1, 0)
        Cells(i + 5, "B").Resize(11) = Application.Transpose(Arr)
    Loop
    Range("B10").CopyFromRecordset Cn.Execute(StrSQL)
End Sub

limonet

关键字：getrows

limonet

Sub limonet()
    Dim Cn As Object, StrSQL$, Arr As Variant, i%, Rst As Object
    Set Cn = CreateObject("Adodb.Connection")
    Cn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties=Excel 12.0;Data Source=" & ThisWorkbook.FullName
    Set Rst = Cn.Execute("Select 姓名,班级 From [名单$B:C]")
    Do Until Rst.EOF
        i = Range("A" & Rows.Count).End(xlUp).Row + 1
        Arr = Rst.GetRows(11)
        Sheet2.Range("A1").CurrentRegion.Copy Cells(i + 1, "A")
        ActiveSheet.PageSetup.PrintArea = Mid(ActiveSheet.PageSetup.PrintArea & "," & Cells(i + 1, "A").CurrentRegion.Address(), 2)
        Cells(i + 2, "C") = Arr(1, 0)
        Cells(i + 5, "B").Resize(11) = Application.Transpose(Arr)
    Loop
End Sub

gwjkkkkk

Option Explicit
Sub TEST1()
    Dim ar, br, cr, i&, j&, m&, n&, tRng As Range, iMsg&, dic As Object, vKey
   
    Application.ScreenUpdating = False
   
    ar = Worksheets("名单").[A1].CurrentRegion.Value
    Set dic = CreateObject("Scripting.Dictionary")
    For i = 2 To UBound(ar)
        dic(ar(i, 2)) = dic(ar(i, 2)) & " " & i
    Next i
   
    For Each vKey In dic.keys
        cr = Split(dic(vKey))
        ReDim br(1 To UBound(cr), 1 To 18)
        For i = 1 To UBound(cr)
            br(i, 1) = i: br(i, 2) = ar(cr(i), 3)
        Next i
        dic(vKey) = br
    Next
   
    Set tRng = Worksheets("记录样表").[A1:R4]
    ar = Worksheets("字典").[A1].CurrentRegion.Value
    With Worksheets("需求效果")
        .Cells.Delete
        For Each vKey In dic.keys
            m = m + 1
            n = .Cells(.Rows.Count, "A").End(xlUp).Row
            n = IIf(n = 1, n, n + 2)
            rngCopyToSame tRng, .Cells(n, 1)
            With .Cells(n, 1)
                .Cells(2, 3).Value = vKey
                For i = 2 To UBound(ar)
                    If ar(i, 1) = vKey Then .Cells(2, 14).Value = ar(i, 2): Exit For
                Next i
            End With
            If m > 1 Then .HPageBreaks.Add Before:=.Cells(n, 1)
            With .Cells(n + 4, 1)
                br = dic(vKey)
                With .Resize(UBound(br), UBound(br, 2))
                    .Value = br
                    .HorizontalAlignment = xlCenter
                    .VerticalAlignment = xlCenter
                    .Borders.LineStyle = xlContinuous
                End With
            End With
        Next
        .Activate
        iMsg = MsgBox("是否预览", vbYesNo + vbInformation, "???")
        If iMsg = vbYes Then .PrintPreview
    End With
   
    Application.ScreenUpdating = True
    Beep
End Sub
Function rngCopyToSame(ByVal rngSel As Range, ByVal rngTarget As Range)
    Dim i&
    rngSel.Copy
    rngTarget.PasteSpecial xlPasteColumnWidths
    rngSel.Copy rngTarget
    With rngTarget.Resize(rngSel.Rows.Count, rngSel.Columns.Count)
        For i = 1 To .Rows.Count
            .Rows(i).RowHeight = rngSel.Rows(i).RowHeight
        Next i
    End With
End Function

ykcbf1100

附件供参考。。。