Sub ChuyenDuLieu()
Dim DT As Worksheet, KQ As Worksheet, Ten As Range
Dim LisDt()
Dim r As Long, rc As Long, rDt1 As Long, rDt2 As Long, r1 As Long, r2 As Long
Dim rKQ As Long, Stt As Long, cKQ As Long
LisDt = Array("", "Name:", "Company Name:", "Designation:", "Telephone:", "Fax:", "Email:", "Company Address:", "Country:", "Company Website:", "Inbound Business:", "Outbound Business:", "No. Consultants:", "No. Tours:", "No. People per Tour:", "Average Length of Stay:", "Totle Air Tickets:", "Hotel Rooms Booked:", "Corporate Travel:", "Leisure Travel:", "Services:", "Products:", "Destinations:")
ThisWorkbook.Activate
Set DT = Sheets("data")
Set KQ = Sheets("KQ")
KQ.Select
Range(Cells(3, 1), Cells(Cells.Rows.Count, 22)).ClearContents
DT.Select
rc = Cells(Cells.Rows.Count, 2).End(xlUp).Row
rDt1 = 1
rDt2 = rc
rKQ = 3
Stt = 1
Do
Set Ten = Range(Cells(rDt1, 1), Cells(rDt2, 1))
For cKQ = 1 To UBound(LisDt)
[B]r1 = Ten.Find(What:=LisDt(cKQ), After:=Cells(rDt1, 1)).Row[/B]
If cKQ < UBound(LisDt) Then
r2 = Ten.Find(What:=LisDt(cKQ + 1), After:=Cells(rDt1, 1)).Row - 1
Else
r2 = Cells(r1, 2).End(xlDown).Row
End If
For r = r1 To r2
KQ.Cells(rKQ + (r - r1), cKQ) = DT.Cells(r, 2)
Next
Next
If Stt Mod 2 = 1 Then
Range(KQ.Cells(rKQ, 1), KQ.Cells(rKQ + (r - r1) - 1, 22)).Font.ColorIndex = 3
Else
Range(KQ.Cells(rKQ, 1), KQ.Cells(rKQ + (r - r1) - 1, 22)).Font.ColorIndex = 11
End If
Stt = Stt + 1
rKQ = rKQ + (r - r1)
rDt1 = r2 + 1
If rDt1 > rc Then Exit Do
Loop
Set DT = Nothing
Set DT = Nothing
End Sub
