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