Sub LayDL_ADO17()
Dim lsSQL As String, cnn As Object, lrs As Object
Dim sh As Worksheet
Dim lr As Long, j As Long, m As Long, k As Long, n As Long
Dim Arr As Variant, ExcelArr As Variant, i As Long, _
c As Long, h As Long, r As Long, v As Long
Set cnn = CreateObject("ADODB.Connection")
Set lrs = CreateObject("ADODB.Recordset")
Set sh = Sheet5
n = 1
m = 7
lr = sh.Range("G" & Rows.Count).End(xlUp).Row
With cnn .ConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0;" & _
"Data Source=" & ThisWorkbook.Path & "\DM.xls" & _
";Extended Properties=""Excel 8.0;HDR=Yes;"";"
.Open
End With
For j = 7 To lr
If sh.Cells(j, 7) = "" Then
Cells(m, 1) = n
Cells(m, 2) = sh.Cells(j + 1, 7).Value
Else
Cells(m, 1) = n
Cells(m, 2) = sh.Cells(j, 7).Value
lsSQL = "SELECT MSVT, HPVT, MA_NC " & _
"FROM [DM$] " & _
"WHERE [MHDM] = '" & Cells(m, 2) & "' "
lrs.Open lsSQL, cnn, 3, 1
Arr = lrs.GetRows
v = UBound(Arr, 1) + 1
h = UBound(Arr, 2) + 1
ReDim ExcelArr(1 To h, 1 To v): r = 0
For i = 1 To h
r = r + 1
For c = 1 To v
ExcelArr(r, c) = Arr(c - 1, i - 1)
Next c
Next i
Sheet5.Range("C" & m+1).Resize(h, v).Value = ExcelArr
k = sh.Range("C" & Rows.Count).End(xlUp).Row
m = k + 1
n = n + 1
lrs.Close: Set lrs = Nothing
cnn.Close: Set cnn = Nothing
End If
Next j
End Sub