[已解决]求助各位老师 关于数据拷贝

古典文学

有需求向大家求助
如附件
例子文件夹里面有 全部数据 工作薄 里面有三列数据
现在想以第一列数据（汉字）为基础，第一列数据相同的三列数据皆拷贝下来然后复制到一个新工作薄中，工作薄的名字就叫第一列的汉字，工作薄放在成果文件夹中。
然后继续复制，最后第一列有多少个不同的名称就在成果文件夹里面生成多少个工作薄。
现在成果文件夹里面有了一个东风胡工作薄 它就是想要的成果
不知道说清楚没有
谢谢各位老师了

最佳答案

月排行榜 / 总排行榜

dsmch

2014-12-16 17:02

………………

跳转到最佳答案楼层

dsmch

1. Sub Macro1()
   
2. Dim arr, sht As Worksheet, i&, n&
   
3. Set sht = ThisWorkbook.Sheets(1)
   
4. arr = Range("a1:c" & Range("a65536").End(xlUp).Row + 1)
   
5. n = 1
   
6. Application.ScreenUpdating = False
   
7. Application.DisplayAlerts = False
   
8. For i = 2 To UBound(arr)
   
9.     If arr(i, 1) <> arr(n, 1) Then
   
10.         With Workbooks.Add
    
11.             sht.Range(sht.Cells(n, 1), sht.Cells(i - 1, 3)).Copy .Sheets(1).[a1]
    
12.             .SaveAs Filename:=ThisWorkbook.Path & "\成果" & arr(n, 1) & ".xls"
    
13.             .Close 1
    
14.         End With
    
15.         n = i
    
16.     End If
    
17. Next
    
18. Application.DisplayAlerts = True
    
19. Application.ScreenUpdating = True
    
20. End Sub

复制代码

dsmch

………………

古典文学

dsmch 发表于 2014-12-16 17:02
………………

实现了 多谢您
设置您为最佳答案

古典文学

dsmch 发表于 2014-12-16 17:02
………………

dsmch 老师
工作中又发现个问题
需要找您修改下代码
增加了一步
如附件
以前是把数据按照第一列名称拷贝出来一个单独的工作薄
现在想以原始数据那个工作薄为基础，就是烤出来的数据要放到以全部数据工作薄为基础的工作薄内
因为新生成的工作薄要用到原始数据工作薄里面的后两个工作表（成果数据和完整数据），拷贝出来的还放在第一个工作表里（即初始数据）。想要的成果还在成果文件夹里面有例子，再次麻烦您 谢谢了。这个实现就不需要在调整了。

dsmch

Sub Macro1()
Dim arr, sht As Worksheet, i&, n&
Set sht = ThisWorkbook.Sheets(1)
arr = Range("a1:c" & Range("a65536").End(xlUp).Row + 1)
n = 1
Application.ScreenUpdating = False
Application.DisplayAlerts = False
For i = 2 To UBound(arr)
    If arr(i, 1) <> arr(n, 1) Then
        With Workbooks.Add
            sht.Range(sht.Cells(n, 1), sht.Cells(i - 1, 3)).Copy .Sheets(1).[a1]
            ThisWorkbook.Sheets(2).UsedRange.Copy .Sheets(2).[a1]
            ThisWorkbook.Sheets(3).UsedRange.Copy .Sheets(3).[a1]
            .Sheets(1).Name = "初始数据"
            .Sheets(2).Name = "成果数据"
            .Sheets(3).Name = "完整数据"   
            .SaveAs Filename:=ThisWorkbook.Path & "\成果\" & arr(n, 1) & ".xls"
            .Close 1
        End With
        n = i
    End If
Next
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub

古典文学

dsmch 发表于 2014-12-17 13:33
Sub Macro1()
Dim arr, sht As Worksheet, i&, n&
Set sht = ThisWorkbook.Sheets(1)

实现了  再次感谢您
这下问题都解决了
祝您愉快