把数据填入其它工作簿

mote66

把数据填入其它工作簿

不知道为什么

如图，看看是不是你需要的效果？

不知道为什么

再看下            

mote66

不知道为什么 发表于 2018-6-25 16:16
再看下

嗯。有代码或者附件么

不知道为什么

mote66 发表于 2018-6-25 16:38
嗯。有代码或者附件么

如图代码供参考。记得给下评分哦，呵呵

chaohuahch

代码如下:  供参考！

1. Sub HCH()
   
2. Application.DisplayAlerts = False
   
3. Application.ScreenUpdating = False
   
4. 
   
5. Dim i, num
   
6. Dim str
   
7. Dim arr, brr()
   
8. For num = 2 To 11
   
9.     i = Sheet1.Cells(1, num).End(xlDown).Row
   
10.    arr = Range(Cells(i - 499, num), Cells(i, num))
    
11. '    arr = Cells(1, num).Offset(499, 1)
    
12.     brr = Array("白色", "金丝", "银丝", "咖啡色", "黑金刚", "天蓝色", "浅蓝色", "橘黄色", "雪牙色", "浅咖啡色")
    
13.     'MsgBox ThisWorkbook.Path
    
14.     'MsgBox brr(0)
    
15.     str = brr(num - 2)
    
16.         Workbooks.Open ThisWorkbook.Path & "" & Range("Q1") & "" & str & ".xlsx"
    
17.         Sheets(1).Activate
    
18.         Range("A1:A500") = arr
    
19.         Workbooks(str & ".xlsx").Close SAVECHANGES:=True
    
20.         Erase arr
    
21. Next
    
22. Application.DisplayAlerts = True
    
23. Application.ScreenUpdating = True
    
24. End Sub

复制代码

如果觉得有用。送朵小花吧！

mote66

chaohuahch 发表于 2018-6-25 21:20
代码如下:  供参考！如果觉得有用。送朵小花吧！

你好~，运行代码后出现错误。

lsc900707

Sub gj23w98()
    Application.DisplayAlerts = False
    Application.ScreenUpdating = False
    p=ThisWorkbook.Path & "/"
    arr = Array("白色", "金丝", "银丝", "咖啡色", "黑金刚", "天蓝色", "浅蓝色", "橘黄色", "雪牙色", "浅咖啡色")
    For j = 2 To 11
        i = Cells(1, j).End(xlDown).Row
        brr = Cells(i - 499, j).Resize(500, 1)
        s = arr(j - 2)
        Set wb = Workbooks.Open( p & [q1] & "/" & s & ".xlsx")
        wb.Sheets(1).[a1].Resize(500, 1) = brr
        wb.Close True
    Next
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
End Sub

chaohuahch

mote66 发表于 2018-6-26 08:15
你好~，运行代码后出现错误。

Workbooks.Open ThisWorkbook.Path & "\" & Range("Q1") & "\" & str & ".xlsx"
这里应该有一个\ 符号

lsc900707

参考附件：