- Tham gia
- 30/5/06
- Bài viết
- 1,798
- Được thích
- 4,706
- Giới tính
- Nam
Tôi viết một thủ tục như sau:
Nhưng sau khi thực hiện màn hình tôi bị như sau:
Lê Văn Duyệt
Mã:
Sub MakeQTFabricList()
Dim wsReport As Worksheet, wsData As Worksheet, wsQT As Worksheet
Dim rngSource As Range, rngRange As Range
Dim sMaterialNo As String, sMaterialDes As String, sQtDes As String
Dim iQuiltedThickness As Integer
Dim i As Long, j As Long, k As Long, iCase As Integer
With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
End With
Set rngSource = Application.Range("tb_Sample")
Set wsData = Application.ThisWorkbook.Worksheets("FABRIC_LIST")
Set wsReport = Application.ThisWorkbook.Worksheets("REPORT")
Set wsQT = Application.ThisWorkbook.Worksheets("QT")
'Clear all at the Report worksheet
wsReport.Cells.ClearFormats
wsReport.Cells.ClearContents
'The first row of the Fabric_List worksheet
i = 4
sMaterialNo = wsData.Cells(i, 1)
'The first row of the Report worksheet
j = 3
'Initial the iCase
iCase = 1
rngSource.Copy
Do While Len(Trim(sMaterialNo)) > 0
Select Case iCase
Case 1 'i.e Quilted ticking with pu thickness 10mm D12, no fibre
With wsReport.Range("A" & j)
.PasteSpecial xlPasteFormulas
.Offset(0, 0) = sMaterialNo
.Offset(1, 3) = 10
End With
Case 2 'i.e Quilted ticking with pu thickness 10mm D20, fibre 300 grm
With wsReport.Range("A" & j)
.PasteSpecial xlPasteFormulas
.Offset(0, 0) = sMaterialNo
.Offset(1, 3) = 10
.Offset(2, 3) = "Y"
End With
Case 3 'i.e Quilted ticking with pu thickness 15mm D20, no fibre
With wsReport.Range("A" & j)
.PasteSpecial xlPasteFormulas
.Offset(0, 0) = sMaterialNo
.Offset(1, 3) = 15
End With
Case 4 'i.e Quilted ticking with pu thickness 20mm D20, no fibre
With wsReport.Range("A" & j)
.PasteSpecial xlPasteFormulas
.Offset(0, 0) = sMaterialNo
.Offset(1, 3) = 20
End With
Case 5 'i.e Quilted ticking with pu thickness 20mm D20, fibre 300 grm
With wsReport.Range("A" & j)
.PasteSpecial xlPasteFormulas
.Offset(0, 0) = sMaterialNo
.Offset(1, 3) = 20
.Offset(2, 3) = "Y"
End With
Case 6 'i.e Quilted ticking with pu thickness 25mm D20, no fibre
With wsReport.Range("A" & j)
.PasteSpecial xlPasteFormulas
.Offset(0, 0) = sMaterialNo
.Offset(1, 3) = 25
End With
Case 7 'i.e Quilted ticking with pu thickness 25mm D20, fibre 300 grm
With wsReport.Range("A" & j)
.PasteSpecial xlPasteFormulas
.Offset(0, 0) = sMaterialNo
.Offset(1, 3) = 25
.Offset(2, 3) = "Y"
End With
Case 8 'i.e Quilted ticking with pu thickness 30mm D20, no fibre
With wsReport.Range("A" & j)
.PasteSpecial xlPasteFormulas
.Offset(0, 0) = sMaterialNo
.Offset(1, 3) = 30
End With
Case 9 'i.e Quilted ticking with pu thickness 30mm D20, fibre 300 grm
With wsReport.Range("A" & j)
.PasteSpecial xlPasteFormulas
.Offset(0, 0) = sMaterialNo
.Offset(1, 3) = 30
.Offset(2, 3) = "Y"
End With
Case 10 'i.e Quilted ticking with pu thickness 35mm D20, fibre 300 grm
With wsReport.Range("A" & j)
.PasteSpecial xlPasteFormulas
.Offset(0, 0) = sMaterialNo
.Offset(1, 3) = 35
.Offset(2, 3) = "Y"
End With
Case 11 'i.e Quilted ticking with pu thickness 35mm D20, fibre 500 grm
With wsReport.Range("A" & j)
.PasteSpecial xlPasteFormulas
.Offset(0, 0) = sMaterialNo
.Offset(1, 3) = 35
.Offset(3, 3) = "Y"
End With
End Select
If iCase = 11 Then
iCase = 1
i = i + 1
sMaterialNo = wsData.Cells(i, 1)
Else
iCase = iCase + 1
End If
j = j + 16
Loop
'Refresh data before continuous
wsReport.Calculate
'Clear the data at QT worksheet
Set rngRange = Application.Range("tb_QT_Del")
rngRange.ClearFormats
rngRange.ClearContents
k = 3
'Then create the Quilted Fabric table
For i = 1 To j
sMaterialNo = wsReport.Cells(i, 1)
sMaterialDes = wsReport.Cells(i, 3)
sQtDes = wsReport.Cells(i, 5)
If Len(Trim(sMaterialNo)) > 0 Then
With wsQT
.Cells(k, 1) = k - 2
.Cells(k, 2) = sQtDes
.Cells(k, 3) = sMaterialNo
.Cells(k, 4) = sMaterialDes
End With
k = k + 1
End If
Next i
'Name the table
Call DefineName("QT", "tb_QT", 3, 2, k - 1, 5)
'Release the memory
Set rngSource = Nothing
Set wsData = Nothing
Set wsReport = Nothing
Set wsQT = Nothing
With Application
.ScreenUpdating = True
.Calculation = xlCalculationAutomatic
End With
'Inform the user
MsgBoxUni VNI("Baïn ñaõ taïo thaønh coâng" & vbCrLf & _
"Danh saùch vaûi ñaõ may chaàn"), vbOKOnly, VNI("Thoâng baùo")
End Sub
Lê Văn Duyệt