求助破解vba

cjc209

Sub 批量导出到模板()
Dim myPath, myName
Dim arr As Variant
Dim i, s As Integer, arr2(), arr1()
Dim wb As Workbook
Set Mapp = CreateObject("Shell.Application").BrowseForFolder(0, "请选择保存结果文件的存放目录：", &H1)
    If Not Mapp Is Nothing Then
        Directory = Mapp.self.Path
    Else
        MsgBox "你没有选择保存目录！": Exit Sub
    End If
Set zsj = Application.InputBox("请点选： 数据源中的任意非空单元格", Type:=8)
Set zdm = Application.InputBox("请在该表中点选 或者框选匹配需要的： 字段名", Type:=8)
arr = zsj.CurrentRegion
gzbm = Application.InputBox("请点选：以什么字段名来命名新工作簿", Type:=8)
For Each zdm1 In zdm
nn = nn + 1
ReDim Preserve arr1(1 To nn)
arr1(nn) = zdm1.Value
Next
    myPath = ThisWorkbook.Path & "\*.xls*"
    myName = Dir(myPath)
    Do While myName <> ""
       If myName <> ThisWorkbook.Name Then mbbm = myName
        myName = Dir()
    Loop
Set wb = Workbooks.Open(ThisWorkbook.Path & "\" & mbbm)
For Each Rng In arr1
  tt = "原始数据中的  " & Rng & "  列匹配到模板中的对应位置："
   n = n + 1
   If Rng = gzbm Then
    bmxh = n
   End If
Set tishi = Application.InputBox(tt, Type:=8)
ReDim Preserve arr2(1 To n)
arr2(n) = tishi.Address(0, 0)
Next Rng
   Application.ScreenUpdating = False
   Application.DisplayAlerts = False
For i = 2 To UBound(arr)

   With wb.Worksheets(1)
   For j = 1 To UBound(arr2)
    For k = 1 To UBound(arr, 2)
     If arr1(j) = arr(1, k) Then
       .Range(arr2(j)) = arr(i, j)
     End If
     Next
   Next
.Copy
bm = arr(i, bmxh)
   ActiveWorkbook.SaveAs Filename:=Directory & "\" & bm & ".xls"
   ActiveWorkbook.Close
End With
Next i
wb.Close False
  Application.DisplayAlerts = True
  Application.ScreenUpdating = True
End Sub

cjc209

可以共享啊 大家用才好 减轻劳动

痛痛痛痛

十分感谢！这里真是excel的家