Sub LayDL_ADO()
Dim i, j, k, irow As Long, irow1, pg As Long
Dim p1, p2, p3 As Long
Dim t As String
Dim text As String
Dim lsSQL As String, Cnn As Object, lrs As Object
ActiveSheet.Unprotect "123"
Sheet1.Range("A3:A1000").Interior.Color = xlNone
ActiveSheet.Protect "123", DrawingObjects:=False, Contents:=True, Scenarios:=False
On Error Resume Next
For i = 3 To Sheet1.Range("A65536").End(xlUp).Row
If Sheet1.Range("E" & i) <> "" Then
Set Cnn = CreateObject("ADODB.Connection")
Set lrs = CreateObject("ADODB.Recordset")
With Cnn
.ConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0;" & _
"Data Source=" & Sheet1.Range("A" & i) & _
";Extended Properties=""Excel 8.0;HDR=No;"";"
.Open
End With
lsSQL = "SELECT * " & "FROM [" & Sheet1.Range("C1") & "$A1:AH50] "
lrs.Open lsSQL, Cnn, 3, 1
With Sheet3
.[A1:AH50].ClearContents
.[A1].CopyFromRecordset lrs
End With
lrs.Close: Set lrs = Nothing
Cnn.Close: Set Cnn = Nothing
'*********************************** copy part 2
Set Cnn = CreateObject("ADODB.Connection")
Set lrs = CreateObject("ADODB.Recordset")
With Cnn
.ConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0;" & _
"Data Source=" & Sheet1.Range("A" & i) & _
";Extended Properties=""Excel 8.0;HDR=No;"";"
.Open
End With
lsSQL = "SELECT * " & "FROM [" & Sheet1.Range("C1") & "$A55:AH65] "
lrs.Open lsSQL, Cnn, 3, 1
With Sheet3
.[A55:A65].ClearContents
.[A55].CopyFromRecordset lrs
End With
lrs.Close: Set lrs = Nothing
Cnn.Close: Set Cnn = Nothing
'*********************************** copy part 3
Set Cnn = CreateObject("ADODB.Connection")
Set lrs = CreateObject("ADODB.Recordset")
With Cnn
.ConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0;" & _
"Data Source=" & Sheet1.Range("A" & i) & _
";Extended Properties=""Excel 8.0;HDR=No;"";"
.Open
End With
lsSQL = "SELECT * " & "FROM [" & Sheet1.Range("C1") & "$A66:AH75] "
lrs.Open lsSQL, Cnn, 3, 1
With Sheet3
.[A66:A75].ClearContents
.[A66].CopyFromRecordset lrs
End With
lrs.Close: Set lrs = Nothing
Cnn.Close: Set Cnn = Nothing
'*********************************** copy part 4
Set Cnn = CreateObject("ADODB.Connection")
Set lrs = CreateObject("ADODB.Recordset")
With Cnn
.ConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0;" & _
"Data Source=" & Sheet1.Range("A" & i) & _
";Extended Properties=""Excel 8.0;HDR=No;"";"
.Open
End With
lsSQL = "SELECT * " & "FROM [" & Sheet1.Range("C1") & "$A120:AH50000] "
lrs.Open lsSQL, Cnn, 3, 1
With Sheet3
.[A120:AH50000].ClearContents
.[A120].CopyFromRecordset lrs
End With
lrs.Close: Set lrs = Nothing
Cnn.Close: Set Cnn = Nothing
irow1 = Sheet3.Cells(Rows.Count, 4).End(xlUp).Offset(1, 0).Row
If irow1 < 149 Then
ActiveSheet.Unprotect "123"
text = "Ba5n ca62n xem la5i to72 khai ha3i quan o73 do2ng so61 " & i
With CreateObject("WScript.Shell")
.Popup UniConvert(text, "VNI"), , "THÔNG BÁO", vbOKOnly
End With
Sheet1.Range("A" & i).Interior.Color = 65535
ActiveSheet.Protect "123", DrawingObjects:=False, Contents:=True, Scenarios:=False
'Informm.thongbao1
'Exit Sub
End If
pg = (irow1 + 22 - 150) / 75
For k = 1 To pg
irow = Sheet2.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
For j = 18 To Sheet1.Range("H2") + 3
If Sheet1.Range("H" & j) = "" Then
Sheet2.Range(Sheet1.Range("J" & j) & irow) = Sheet3.Range(Sheet1.Range("I" & j))
Else
Sheet2.Range(Sheet1.Range("J" & j) & irow) = Sheet3.Range("C" & (150 + (k - 1) * 75)).Offset(Sheet1.Range("H" & j), Sheet1.Range("I" & j))
End If
Next
Sheet2.Range(Sheet1.Range("J17") & irow) = Left(Sheet3.Range(Sheet1.Range("I17")), 10) ' Ngay dk
Sheet2.Range(Sheet1.Range("J4") & irow) = Left(Sheet3.Range(Sheet1.Range("I4")), 3) ' Loai hinh
Sheet2.Range(Sheet1.Range("J5") & irow) = Right(Sheet3.Range(Sheet1.Range("I5")), Len(Sheet3.Range(Sheet1.Range("I5"))) - 4) 'So invoice
Sheet2.Range(Sheet1.Range("J6") & irow) = remmm(Sheet3.Range("C" & (150 + (k - 1) * 75)).Offset(Sheet1.Range("H6"), Sheet1.Range("I6"))) ' So TT
Sheet2.Range(Sheet1.Range("J11") & irow) = remd(Sheet3.Range("C" & (150 + (k - 1) * 75)).Offset(Sheet1.Range("H11"), Sheet1.Range("I11"))) ' So luong
Sheet2.Range(Sheet1.Range("J13") & irow) = chg(Sheet3.Range("C" & (150 + (k - 1) * 75)).Offset(Sheet1.Range("H13"), Sheet1.Range("I13"))) ' Tri gia hoa don
Sheet2.Range(Sheet1.Range("J15") & irow) = chg(Sheet3.Range("C" & (150 + (k - 1) * 75)).Offset(Sheet1.Range("H15"), Sheet1.Range("I15"))) ' Tien thue nhap khau
Sheet2.Range(Sheet1.Range("J12") & irow) = chgd(Sheet3.Range("C" & (150 + (k - 1) * 75)).Offset(Sheet1.Range("H12"), Sheet1.Range("I12"))) ' Don gia
Sheet2.Range(Sheet1.Range("J14") & irow) = remm(Sheet3.Range("C" & (150 + (k - 1) * 75)).Offset(Sheet1.Range("H14"), Sheet1.Range("I14"))) ' Thue XNK %
If Sheet3.Range("H178") = Sheet1.Range("H16") Then
Sheet2.Range(Sheet1.Range("J16") & irow) = chg(Sheet3.Range("C" & (150 + (k - 1) * 75)).Offset(36, Sheet1.Range("I16")))
Sheet2.Range(Sheet1.Range("J33") & irow) = chg(Sheet3.Range("C" & (150 + (k - 1) * 75)).Offset(31, Sheet1.Range("I16")))
Else:
Sheet2.Range(Sheet1.Range("J16") & irow) = chg(Sheet3.Range("C" & (150 + (k - 1) * 75)).Offset(31, Sheet1.Range("I16")))
End If ' Tien thue VAT & thue CBPG
If Left(Sheet3.Range(Sheet1.Range("I4")), 3) = "E31" Then 'A12 7 E31
t = Sheet3.Range("C" & (150 + (k - 1) * 75)).Offset(Sheet1.Range("H" & 7), Sheet1.Range("I" & 7))
p1 = Application.WorksheetFunction.Find(":", t)
p2 = Application.WorksheetFunction.Find("x", LCase(t))
p3 = Application.WorksheetFunction.Find("#&", t)
Sheet2.Range(Sheet1.Range("J7") & irow) = Left(t, p3 - 1) 'Mă NPL / SP
Sheet2.Range(Sheet1.Range("J8") & irow) = LCase(Mid(t, p1 + 1, p2 - p1 - 1)) 'Thickness
Sheet2.Range(Sheet1.Range("J9") & irow) = LCase(Mid(t, p2 + 1, Len(t) - p2)) 'Width
Sheet2.Range(Sheet1.Range("J10") & irow) = Right(t, Len(t) - p3 - 1) 'Ten hang
Else
t = Sheet3.Range("C" & (150 + (k - 1) * 75)).Offset(Sheet1.Range("H" & 7), Sheet1.Range("I" & 7))
p1 = Application.WorksheetFunction.Find(":", t)
p2 = Application.WorksheetFunction.Find("x", LCase(t))
Sheet2.Range(Sheet1.Range("J8") & irow) = LCase(Mid(t, p1 + 1, p2 - p1 - 1)) 'Thickness
Sheet2.Range(Sheet1.Range("J9") & irow) = LCase(Mid(t, p2 + 1, Len(t) - p2)) 'Width
Sheet2.Range(Sheet1.Range("J10") & irow) = t 'Ten hang
End If
Next
End If
Next
End Sub