求助宏制表中每个工作表中的内容不一致

高飞扬

AA.rar (46.02 KB, 下载次数: 3)

2014-8-8 10:30 上传

点击文件名下载附件

附件中，按供方制表，做出来的格式是按每个供方名称命名的，单个供方工作表里面的供方应该是同一个，而现在做出来里面有点乱，求修改一下，能够同一个供方里面就只有这个供方的数据。

chxw68

1. Sub test()
   
2.   Dim cnn As New ADODB.Connection
   
3.   Dim rs As New ADODB.Recordset
   
4.   Dim sql As String
   
5.   Dim mybook As String
   
6.   Dim ws As Worksheet
   
7.   Application.ScreenUpdating = False
   
8.   Application.DisplayAlerts = False
   
9.   mybook = ThisWorkbook.FullName
   
10.   For Each ws In Worksheets
    
11.     If ws.Name <> "A" And ws.Name <> "B" Then
    
12.       ws.Delete
    
13.     End If
    
14.   Next
    
15.   With cnn
    
16.     If Application.Version = "11.0" Then
    
17.       .Provider = "microsoft.jet.oledb.4.0"
    
18.       .ConnectionString = "extended properties=""excel 8.0;HDR=YES;"";data source=" & mybook
    
19.     Else
    
20.       .Provider = "microsoft.ACE.oledb.12.0"
    
21.       .ConnectionString = "extended properties=""excel 12.0;HDR=YES;"";data source=" & mybook
    
22.     End If
    
23.     .Open
    
24.   End With
    
25.   sql = "select distinct 供方名称 from [B$b3:b]"
    
26.   arr = Application.Transpose(Application.Transpose(cnn.Execute(sql).GetRows()))
    
27.   For i = 1 To UBound(arr)
    
28.     sql = "select * from [B$a3:l] where 供方名称='" & arr(i) & "'"
    
29.     rs.Open sql, cnn, adOpenKeyset, adLockOptimistic
    
30.     Set ws = Worksheets.Add(after:=Worksheets(Worksheets.Count))
    
31.     With ws
    
32.       .Name = arr(i)
    
33.       For j = 0 To rs.Fields.Count - 1
    
34.         .Cells(1, j + 1) = rs.Fields(j).Name
    
35.       Next
    
36.       .Range("a2").CopyFromRecordset rs
    
37.       .Columns("a:l").EntireColumn.AutoFit
    
38.       .Columns("i:j").ColumnWidth = 6.5
    
39.       With ActiveSheet.PageSetup
    
40.         .PrintTitleRows = "$1:$12"
    
41.         .CenterHeader = "&18原材料、外购外协件检验台账" '页眉/自定义页眉：中(C)
    
42.         .RightHeader = " №：" & "&P    "
    
43.         .LeftHeader = "HW/JL 8.4-01 " '自定义页眉：左(L)
    
44.         .LeftMargin = Application.InchesToPoints(0.1)  '页边距：左(L)_1.9厘米
    
45.         .RightMargin = Application.InchesToPoints(0.1) '页边距：右(R)_1.9厘米
    
46.         .TopMargin = Application.InchesToPoints(1) '页边距：上(T)_2.5厘米
    
47.         .BottomMargin = Application.InchesToPoints(1) '页边距：下(B)_2.5厘米
    
48.         .HeaderMargin = Application.InchesToPoints(0.5) '页边距：页眉(A)_1.3厘米
    
49.         .FooterMargin = Application.InchesToPoints(0.5) '页边距：页脚(F)_1.3厘米
    
50.         .CenterHorizontally = False '页边距居中方式：水平(Z)
    
51.         .CenterVertically = False '页边距居中方式：垂直(V)
    
52.         .Orientation = xlLandscape '页面方向：纵向(T) xlPortrait/ 横向 (L)xlLandscape
    
53.         .PaperSize = xlPaperA4 '页面纸张大小(Z)：A4
    
54.         .FirstPageNumber = xlAutomatic '页面起始页码：自动
    
55.         .Zoom = 100 '页面缩放比例：100% 若选择页面缩放比例，则下面两项没有。
    
56.       End With
    
57.     End With
    
58.     rs.Close
    
59.   Next
    
60. End Sub
    

复制代码

chxw68

用ADO+SQL重新写了一段代码，设定格式的代码是把楼主的照搬过来了。

chxw68

楼主的代码没有大错误，就是下面红色语句有错，数组arr应该从第一行开始取数，这样就和后面的一致了。
Sub 拆分()  '按条件拆分成表保存为工作簿在同文件夹内
    Dim wb As Workbook, arr, rng As Range, d As Object, k, t, sh As Worksheet, i&
    Set rng = Range("a3:l3")
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    arr = Range("b1:b" & Range("b65536").End(xlUp).Row)
   Set d = CreateObject("scripting.dictionary")
    For Each ws In Worksheets
      If ws.Name <> "A" And ws.Name <> "B" Then
        ws.Delete
      End If
    Next
    For i = 4 To UBound(arr)
       ' If IsNumeric(arr(i, 1)) Then
            If Not d.Exists(arr(i, 1)) Then
                Set d(arr(i, 1)) = Cells(i, 1).Resize(1, 12)
            Else
                Set d(arr(i, 1)) = Union(d(arr(i, 1)), Cells(i, 1).Resize(1, 12))
           ' End If
        End If
    Next
    k = d.Keys
    t = d.Items
   With Sheets
        For i = 0 To d.Count - 1
            With .Add(after:=.Item(.Count))
                .Name = k(i)
            rng.Copy .Range("A1")
            t(i).Copy .Range("A2")
            .Columns("a:l").EntireColumn.AutoFit
            .Columns("i:j").ColumnWidth = 6.5
            Rows("1:56565").AutoFit
            With ActiveSheet.PageSetup
            .PrintTitleRows = "$1:$12"
.CenterHeader = "&18原材料、外购外协件检验台账" '页眉/自定义页眉：中(C)
.RightHeader = " №：" & "&P    "
.LeftHeader = "HW/JL 8.4-01 " '自定义页眉：左(L)
.LeftMargin = Application.InchesToPoints(0.1)  '页边距：左(L)_1.9厘米
.RightMargin = Application.InchesToPoints(0.1) '页边距：右(R)_1.9厘米
.TopMargin = Application.InchesToPoints(1) '页边距：上(T)_2.5厘米
.BottomMargin = Application.InchesToPoints(1) '页边距：下(B)_2.5厘米
.HeaderMargin = Application.InchesToPoints(0.5) '页边距：页眉(A)_1.3厘米
.FooterMargin = Application.InchesToPoints(0.5) '页边距：页脚(F)_1.3厘米
.CenterHorizontally = False '页边距居中方式：水平(Z)
.CenterVertically = False '页边距居中方式：垂直(V)
.Orientation = xlLandscape '页面方向：纵向(T) xlPortrait/ 横向 (L)xlLandscape
.PaperSize = xlPaperA4 '页面纸张大小(Z)：A4
.FirstPageNumber = xlAutomatic '页面起始页码：自动
.Zoom = 100 '页面缩放比例：100% 若选择页面缩放比例，则下面两项没有。
End With
End With
    Next
    End With
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    MsgBox "完毕"
End Sub

高飞扬

非常感谢指点！