Sub tach()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim i As Long, arr, link As String, cn As Object, sql As String, tenfile As String, wb As Workbook, tong
Set cn = CreateObject("ADODB.Connection")
Set tong = ActiveWorkbook.Sheets("sheet1")
link = ThisWorkbook.Path & "\Data.xlsx"
cn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & link & ";Extended Properties=""Excel 12.0;HDR=No"";"
sql = "Select * From [Sheet1$B3:D10000] where f1 is not null"
arr = ADO_ToArray(cn, sql)
For i = 1 To UBound(arr)
With tong
.Range("D6").Value = arr(i, 1)
.Range("c7").Value = arr(i, 2)
.Range("c8").Value = arr(i, 3)
.Copy
Set wb = ActiveWorkbook
tenfile = ThisWorkbook.Path & "\" & i & ".xlsx"
wb.SaveAs tenfile
wb.Close
End With
Next i
Set cn = Nothing
Set tong = Nothing
Set wb = Nothing
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
Private Function ADO_ToArray(ByRef cn, ByVal sqlStr As String) As Variant
Dim sArr, Res(), i As Long, j As Long
sArr = cn.Execute(sqlStr).getrows
ReDim Res(1 To UBound(sArr, 2) + 1, 1 To UBound(sArr, 1) + 1)
For i = LBound(sArr, 2) To UBound(sArr, 2)
For j = LBound(sArr, 1) To UBound(sArr, 1)
Res(i + 1, j + 1) = sArr(j, i)
Next j
Next i
ADO_ToArray = Res
End Function
