Excel学习----一键创建相应“惟一性”的文件，再筛选数据并写入相应的文件中

Excel学习----一键创建相应“惟一性”的文件，再筛选数据并写入相应的文件中

我们的口号是：Excel会用的是excel,不会用的是电子表格

领导是要求是：有这样的一个表格，请按“模板”文件，建立面试级别的几个文件，并筛选出相应的内容填写到各工作簿中，

常规的做法是：~~~~~~~~~头痛啦

目标：是把多次多次多次“打开文件”---“复制”---“粘贴”—“关闭文件”的工作化为“一键完成”

问题1：一键复制模板文件并按D列“惟一性”命名

问题2：分别筛选出相应的数据并写入到相应文件中，如：把“初中语文1组”的相应的数据填写到“初中语文1组.xlsm”文件中，把“小学数学1组”的相应的数据填写到“小学数学1组.xlsm”文件中，

====这是开始的两个文件========

=====代码在“控制文件.xlsm”中=====

代码如下：

Sub copy_test() ‘一键按复制模板文件并按D列惟一性命名

Dim r%, i%, pa, mfile, topath, f_num

Dim arr, brr

Dim d As Object

f_num = 4

pa = ThisWorkbook.path

mfile = pa & "\模板.xlsm"

topath = pa & "\files\"

If Dir(topath) = "" Then MkDir topath

Set d = CreateObject("scripting.dictionary")

With Worksheets("sheet1")

r = .Cells(.Rows.Count, 2).End(xlUp).Row

'MsgBox r

arr = .Range(Cells(2, f_num), Cells(r, f_num))

For i = 1 To UBound(arr)

d(arr(i, 1)) = ""

Next

End With

brr = d.keys

For i = 0 To UBound(brr)

FileCopy mfile, topath & brr(i) & ".xlsm"

Next

End Sub

Sub copy_data_file()‘分别筛选并写入相应的文件

Dim r%, i%, pa, mfile, topath, Lcol, j, crr_i, f_num

Dim arr, brr, crr(1 To 100, 1 To 3)

Dim d As Object, rng As Range, wb As Workbook, this_sht As Worksheet

f_num = 4

pa = ThisWorkbook.path

topath = pa & "\files\"

Set d = CreateObject("scripting.dictionary")

Application.ScreenUpdating = False

Application.DisplayAlerts = False

Set this_sht = Worksheets("Sheet1")

With Worksheets("Sheet1")

r = .Cells(.Rows.Count, 2).End(xlUp).Row

Lcol = .Range("a1").End(xlToRight).Column

'MsgBox Lcol

arr = .Range("a2").Resize(r - 1, Lcol)

'crr = .Range("a1").rezise(r, Lcol)

For i = 2 To UBound(arr)

d(arr(i, f_num)) = ""

Next i

End With

brr = d.keys

For i = 0 To UBound(brr)

crr_i = 1

For j = 2 To UBound(arr)

If arr(j, f_num) = brr(i) Then

crr(crr_i, 1) = arr(j, 1)

crr(crr_i, 2) = arr(j, 2)

crr(crr_i, 3) = arr(j, 3)

crr_i = crr_i + 1

End If

Next j

Set wb = Workbooks.Open(topath & brr(i) & ".xlsm")

wb.Worksheets("Sheet1").Range("a2").Resize(UBound(crr,1), UBound(crr, 2)) = crr

wb.Save: wb.Close True

Erase crr

Next i

Application.DisplayAlerts = True

Application.ScreenUpdating = True

End Sub

运行~~~~成功

【一键按复制模板文件并按D列惟一性命名】按钮~~~~~成功

【分别筛选并写入相应的文件】按钮~~~~~成功