Chuyên đề giải đáp những thắc mắc về code VBA

Maika8008

Thành viên từ sao Hỏa
Tham gia ngày
12 Tháng sáu 2020
Bài viết
587
Được thích
498
Điểm
85
chào các cao nhận ạ, e có sưu tầm được 1 file vba về lấy link trong thư mục ra excel. tuy nhiên kết quả mặt định gán về cột A. nhờ các cao nhân chỉnh sửa gán về cột H được không ạ.
Cảm ơn các ạnh nhiều, mong nhận được sự giúp đỡ ạ
------
Sub Hyper()
Dim xFSO As Object
Dim xFolder As Object
Dim xFile As Object
Dim xFiDialog As FileDialog
Dim xPath As String
Dim I As Integer
Set xFiDialog = Application.FileDialog(msoFileDialogFolderPicker)
If xFiDialog.Show = -1 Then
xPath = xFiDialog.SelectedItems(1)
End If
Set xFiDialog = Nothing
If xPath = "" Then Exit Sub
Set xFSO = CreateObject("Scripting.FileSystemObject")
Set xFolder = xFSO.GetFolder(xPath)
For Each xFile In xFolder.Files
I = I + 1
ActiveSheet.Hyperlinks.Add Cells(I, 1), xFile.Path, , , xFile.Name
Next
End Sub
-------
Sửa số 1 là A thành số cột bạn muốn 8 là H tại dòng ActiveSheet.Hyperlinks.Add Cells(I, 1), xFile.Path, , , xFile.Name
 

thnghiachau

Thành viên tiêu biểu
Tham gia ngày
14 Tháng chín 2009
Bài viết
705
Được thích
560
Điểm
860
chào các cao nhận ạ, e có sưu tầm được 1 file vba về lấy link trong thư mục ra excel. tuy nhiên kết quả mặt định gán về cột A. nhờ các cao nhân chỉnh sửa gán về cột H được không ạ.
Cảm ơn các ạnh nhiều, mong nhận được sự giúp đỡ ạ
------
Sub Hyper()
Dim xFSO As Object
Dim xFolder As Object
Dim xFile As Object
Dim xFiDialog As FileDialog
Dim xPath As String
Dim I As Integer
Set xFiDialog = Application.FileDialog(msoFileDialogFolderPicker)
If xFiDialog.Show = -1 Then
xPath = xFiDialog.SelectedItems(1)
End If
Set xFiDialog = Nothing
If xPath = "" Then Exit Sub
Set xFSO = CreateObject("Scripting.FileSystemObject")
Set xFolder = xFSO.GetFolder(xPath)
For Each xFile In xFolder.Files
I = I + 1
ActiveSheet.Hyperlinks.Add Cells(I, 1), xFile.Path, , , xFile.Name
Next
End Sub
-------
bạn coi cái dòng này: ActiveSheet.Hyperlinks.Add Cells(I, 1), xFile.Path, , , xFile.Name
chỉnh lại cái in đậm theo bạn muốn
 

huuthang_bd

Chuyên gia GPE
Tham gia ngày
10 Tháng chín 2008
Bài viết
7,955
Được thích
9,298
Điểm
860
Nơi ở
TP.HCM
Sửa thẳng thành chữ H luôn để sau này bạn có muốn sửa thì còn nhớ.
Rich (BB code):
Sub Hyper()
    Dim xFSO As Object
    Dim xFolder As Object
    Dim xFile As Object
    Dim xFiDialog As FileDialog
    Dim xPath As String
    Dim I As Integer
    Set xFiDialog = Application.FileDialog(msoFileDialogFolderPicker)
    If xFiDialog.Show = -1 Then
        xPath = xFiDialog.SelectedItems(1)
    End If
    Set xFiDialog = Nothing
    If xPath = "" Then Exit Sub
    Set xFSO = CreateObject("Scripting.FileSystemObject")
    Set xFolder = xFSO.GetFolder(xPath)
    For Each xFile In xFolder.Files
        I = I + 1
        ActiveSheet.Hyperlinks.Add Cells(I, "H"), xFile.Path, , , xFile.Name
    Next
End Sub
 

Love GPE

Thành viên mới
Tham gia ngày
17 Tháng hai 2020
Bài viết
34
Được thích
14
Điểm
15
Em có đoạn code dưới đây. Em đang tập tành lấy tên khách hàng từ listbox vào textbox.
Hiện tại khi em gõ tên khách hàng vào textbox -> đã thấy khách hàng ở dưới listbox rồi. Nhưng em dùng phím mũi tên để di chuyển xuống listbox chọn khách hàng thì ko xuống được. Em đang thử để setfocus cho lisbox (chỗ chữ em tô đỏ ở dưới code) - thì chưa kịp gõ đến chữ thứ 2 thì nó đã chuyển xuống lisbox mất rồi.
Em mong muốn GPE giúp Em .... sau khi gõ tìm kiếm khách hàng ở textbox -> thấy khách hàng cần tìm thì bấm mũi tên xuống -> con trỏ chuột sẽ chuyển xuống listbox để chọn khách hàng -> Bấm enter thì khách hàng sẽ được chọn vào textbox. Mong GPE giúp đỡ Em với ạ. Cảm ơn GPE rất nhiều!



Private Sub LxB_KhachHang_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
If KeyAscii = vbKeyReturn Then
TxB_KhachHang.Value = LxB_KhachHang.Value
LxB_KhachHang.Height = 0
End If
End Sub

Private Sub TxB_KhachHang_change()
LxB_KhachHang.Clear
LxB_KhachHang.Visible = True
LxB_KhachHang.Height = 150
LxB_KhachHang.Width = 400
LxB_KhachHang.List = Filter(WorksheetFunction.Transpose(Range("Name_KhachHang")), TxB_KhachHang.Value, True, vbTextCompare)
LxB_KhachHang.SetFocus
End Sub
 
Lần chỉnh sửa cuối:

ptm0412

Bad Excel Member
Thành viên BQT
Super Moderator
Tham gia ngày
4 Tháng mười một 2007
Bài viết
10,019
Được thích
29,925
Điểm
1,910
Tuổi
58
Nơi ở
Gò Vấp
Em có đoạn code dưới đây. Em đang tập tành lấy tên khách hàng từ listbox vào textbox.
Hiện tại khi em gõ tên khách hàng vào textbox -> đã thấy khách hàng ở dưới listbox rồi. Nhưng em dùng phím mũi tên để di chuyển xuống listbox chọn khách hàng thì ko xuống được. Em đang thử để setfocus cho lisbox (chỗ chữ em tô đỏ ở dưới code) - thì chưa kịp gõ đến chữ thứ 2 thì nó đã chuyển xuống lisbox mất rồi.
Em mong muốn GPE giúp Em .... sau khi gõ tìm kiếm khách hàng ở textbox -> thấy khách hàng cần tìm thì bấm mũi tên xuống -> con trỏ chuột sẽ chuyển xuống listbox để chọn khách hàng -> Bấm enter thì khách hàng sẽ được chọn vào textbox. Mong GPE giúp đỡ Em với ạ. Cảm ơn GPE rất nhiều!
Câu lệnh setFocus để trong thủ tục KeyDown của textbox, Keycode = 40. Xuống listBox rồi nhấn enter thì cũng dùng thủ tục keyDown, KeyCode = 13
 

Love GPE

Thành viên mới
Tham gia ngày
17 Tháng hai 2020
Bài viết
34
Được thích
14
Điểm
15
Câu lệnh setFocus để trong thủ tục KeyDown của textbox, Keycode = 40. Xuống listBox rồi nhấn enter thì cũng dùng thủ tục keyDown, KeyCode = 13
Em cảm ơn Thầy ptm0412 rất nhiều! Em sửa lệnh như chỗ tô mầu xanh. Để setfocus trong thủ tục Keydown với điều kiện keycode = 40 thì setfocus xuống lisbox được rồi Thầy ạ.

Private Sub LxB_KhachHang_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
If KeyAscii = vbKeyReturn Then
TxB_KhachHang.Value = LxB_KhachHang.Value
LxB_KhachHang.Height = 0
End If
End Sub
Private Sub TxB_KhachHang_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
LxB_KhachHang.Clear
LxB_KhachHang.Visible = True
LxB_KhachHang.Height = 150
LxB_KhachHang.Width = 400
LxB_KhachHang.List = Filter(WorksheetFunction.Transpose(Range("Name_KhachHang")), TxB_KhachHang.Value, True, vbTextCompare)
If KeyCode = 40 Then
LxB_KhachHang.SetFocus
End If

End Sub
 

moihocvba

Thành viên mới
Tham gia ngày
16 Tháng tám 2020
Bài viết
12
Được thích
0
Điểm
13
Tuổi
22
Mọi người cho hỏi, trong sheet để ngăn sự kiện chạy thì mình dùng Application.EnableEvents = False, còn trong userform để ngăn sự kiện Textbox1_Change thì mình dùng lệnh nào ạ?
Để trong một số trường hợp mình gõ vào textbox1 đó thì lệnh Textbox1_Change ko thực thi nữa đó ạ?
Cảm ơn đã giải đáp!
 
Lần chỉnh sửa cuối:

thnghiachau

Thành viên tiêu biểu
Tham gia ngày
14 Tháng chín 2009
Bài viết
705
Được thích
560
Điểm
860
Mọi người cho hỏi, trong sheet để ngăn sự kiện chạy thì mình dùng Application.EnableEvents = False, còn trong user để ngăn sự kiện Textbox1_Change thì mình dùng lệnh nào ạ?
Để trong một số trường hợp mình gõ vào textbox1 đó thì lệnh Textbox1_Change ko thực thi nữa đó ạ?
Cảm ơn đã giải đáp!
Hình như là không có thì phải...
Bạn tạo biến Public (vd: blEnableEvents chẳng hạn)
và đầu mỗi sự kển bạn kiểm tra biến này
If Not blblEnableEvents then exit sub
 

tigertiger

Coming back ...
Tham gia ngày
25 Tháng một 2007
Bài viết
1,696
Được thích
1,598
Điểm
860
Mọi người cho hỏi, trong sheet để ngăn sự kiện chạy thì mình dùng Application.EnableEvents = False, còn trong userform để ngăn sự kiện Textbox1_Change thì mình dùng lệnh nào ạ?
Để trong một số trường hợp mình gõ vào textbox1 đó thì lệnh Textbox1_Change ko thực thi nữa đó ạ?
Cảm ơn đã giải đáp!
Thì bạn căn cứ vào cái màu đỏ đó mà đặt điều kiện ở đầu sub sự kiện Textbox1_Change chẳng hạn - để Exit sub, hay chạy code
 

tkhieu

Thành viên mới
Tham gia ngày
13 Tháng chín 2013
Bài viết
37
Được thích
1
Điểm
365
Tuổi
30
Nhờ mọi người giúp mình đoạn code tạo chữ ký dưới bảng pivottable với ạ
 

File đính kèm

quochr

Thành viên mới
Tham gia ngày
14 Tháng tám 2013
Bài viết
18
Được thích
2
Điểm
365
Tuổi
33
Nhờ mọi người hỗ trợ về code in hàng loạt (nội dung chi tiết trên file đính kèm).
1/ File code print ot có sheep mình cần in hàng loạt để gởi cho công nhân (code mình sưu tầm từ đây: file đính kèm file test_in)
Bên dưới là code để add sign for button trong file test_in. Mình đọc code mà do ko chuyên về VBA nên khi copy code để add vào file thì nó báo lỗi " If sotrang > 1 Then" và cũng không hiểu lắm. Bạn nào biết hướng dẫn giúp mình.
2/ Phần funtion để viết chuyển từ hàng xuống cột mình viết hoi bị thủ công, có bạn nào có công thức hay hơn hoặc cách hay hơn chỉ giúp mình luôn.
Thủ đức hoặc loanh quanh gần mình mời cà phê để được học hỏi thêm càng tốt ạ ^^
THanks,
Mã:
Attribute VB_Name = "in_hang_loat"
Sub inhangloat()
Attribute inhangloat.VB_ProcData.VB_Invoke_Func = " \n14"
   
    Dim tinhtoan As Variant
    Dim manhinh As Boolean
    Dim rng, rng1, rng2 As Range
    Dim t1, t2, sh2, sh1, add_rng1 As String
    Dim sotrang, k As Integer
    Dim she As Sheets
   
    On Error GoTo thoat
    manhinh = Application.ScreenUpdating
   
    tinhtoan = Application.Calculation
    Application.Calculation = xlCalculationManual
    Application.Calculation = xlCalculationManual
   
    '---------------------
    Set rng1 = Application.InputBox("nhap vao dia chi output", Type:=8)
    If rng1.Count <> 1 Then
        MsgBox "chon sai so ô, chi duoc chon 1 ô"
        Exit Sub
    End If
   
    add_rng1 = rng1.Address
    '---------------------
   
    Set rng2 = Application.InputBox("nhap vao dia chi input", Type:=8)
    Application.ScreenUpdating = False
    sotrang = rng2.Count
    For Each rng In rng2
        If rng.EntireRow.Hidden = True Or rng.Text = "" Then
            sotrang = sotrang - 1
        End If
    Next
   
    '---------------------(1)
    'Mo 1 workbook moi
    t1 = ActiveWorkbook.Name
    sh1 = ActiveSheet.Name
    Sheets(sh1).Select
    Sheets(sh1).Copy
    t2 = ActiveWorkbook.Name
    sh2 = ActiveSheet.Name
    '---------------------(1)
   
   
    '---------------------(2)
    'tao ra cac sheet
    If sotrang > 1 Then
       For i = 1 To sotrang - 1
           Workbooks(t2).Sheets(sh2).Select
           Workbooks(t2).Sheets(sh2).Copy Before:=Sheets(sh2)
       Next
    End If
    '----------------------(2)
   
   
    '------------------------------(3)
    ' Lay gia tri tu rng2 thay vao cac sheet
    k = 0
    For Each rng In rng2
        If rng.EntireRow.Hidden = False And rng.Text <> "" Then
          k = k + 1
          Workbooks(t2).Sheets(k).Range(add_rng1).Value = rng.Value
        End If
    Next
   
    Application.Calculation = xlCalculationAutomatic
    '------------------------------(3)
   
    Application.ScreenUpdating = manhinh
   
    t = Application.Dialogs(xlDialogPrinterSetup).Show
    Workbooks(t2).PrintOut ActivePrinter:=t
   
    Workbooks(t2).Close False
   
thoat:
    Application.Calculation = tinhtoan
    Application.ScreenUpdating = manhinh
   
End Sub
 

File đính kèm

Lần chỉnh sửa cuối:

quochr

Thành viên mới
Tham gia ngày
14 Tháng tám 2013
Bài viết
18
Được thích
2
Điểm
365
Tuổi
33
All Done!
 
Lần chỉnh sửa cuối:

vova2209

Thành viên tiêu biểu
Tham gia ngày
5 Tháng tư 2017
Bài viết
642
Được thích
73
Điểm
220
Tuổi
34
Nơi ở
TP. Tuyên Quang
Chào Anh Chị! em có 1 code ở trên mang về dãn dòng, khi kích sửa trực tiếp thì sẽ tự động co về vừa chữ. Anh Chị chỉnh lại hộ em khi tự động co về "Chiều cao dòng tối thiểu là 18"
Mã:
Private Sub Worksheet_Change(ByVal Target As Range)
    Dim NewRwHt As Single
    Dim cWdth As Single, MrgeWdth As Single
    Dim c As Range, cc As Range
    Dim ma As Range
    ActiveSheet.DisplayPageBreaks = False

    With Target
        If .MergeCells And .WrapText Then
        Set c = Target.Cells(1, 1)
            cWdth = c.ColumnWidth
        Set ma = c.MergeArea
        For Each cc In ma.Cells
            MrgeWdth = MrgeWdth + cc.ColumnWidth
        Next
        Application.ScreenUpdating = False
            ma.MergeCells = False
            c.ColumnWidth = MrgeWdth
            c.EntireRow.AutoFit
            NewRwHt = c.RowHeight
            c.ColumnWidth = cWdth
            ma.MergeCells = True
            ma.RowHeight = NewRwHt
            cWdth = 0: MrgeWdth = 0
        Application.ScreenUpdating = True
        End If
    End With
End Sub
 

thnghiachau

Thành viên tiêu biểu
Tham gia ngày
14 Tháng chín 2009
Bài viết
705
Được thích
560
Điểm
860
Chào Anh Chị! em có 1 code ở trên mang về dãn dòng, khi kích sửa trực tiếp thì sẽ tự động co về vừa chữ. Anh Chị chỉnh lại hộ em khi tự động co về "Chiều cao dòng tối thiểu là 18"
Mã:
Private Sub Worksheet_Change(ByVal Target As Range)
    Dim NewRwHt As Single
    Dim cWdth As Single, MrgeWdth As Single
    Dim c As Range, cc As Range
    Dim ma As Range
    ActiveSheet.DisplayPageBreaks = False

    With Target
        If .MergeCells And .WrapText Then
        Set c = Target.Cells(1, 1)
            cWdth = c.ColumnWidth
        Set ma = c.MergeArea
        For Each cc In ma.Cells
            MrgeWdth = MrgeWdth + cc.ColumnWidth
        Next
        Application.ScreenUpdating = False
            ma.MergeCells = False
            c.ColumnWidth = MrgeWdth
            c.EntireRow.AutoFit
            NewRwHt = c.RowHeight
            c.ColumnWidth = cWdth
            ma.MergeCells = True
            ma.RowHeight = NewRwHt
            cWdth = 0: MrgeWdth = 0
        Application.ScreenUpdating = True
        End If
    End With
End Sub
thay
ma.RowHeight = NewRwHt
thành
ma.RowHeight = IIf(NewRwHt>=18,NewRwHt,18)
 

vova2209

Thành viên tiêu biểu
Tham gia ngày
5 Tháng tư 2017
Bài viết
642
Được thích
73
Điểm
220
Tuổi
34
Nơi ở
TP. Tuyên Quang
Lần chỉnh sửa cuối:

hoanglocphat

Thành viên thường trực
Tham gia ngày
27 Tháng một 2013
Bài viết
251
Được thích
30
Điểm
385
Các bạn cho hỏi có cách nào gán 1 macro vào cell A1 của sheet Menu không? để khi ta nhấn ô A1 thì nó chay code không?
(đã tìm trong Hyperlink nhưng không có đường link dẫn đến macro)
Cảm ơn các bạn nhiều!
 

snow25

Thành viên gắn bó
Tham gia ngày
24 Tháng bảy 2018
Bài viết
2,718
Được thích
2,669
Điểm
360
Các bạn cho hỏi có cách nào gán 1 macro vào cell A1 của sheet Menu không? để khi ta nhấn ô A1 thì nó chay code không?
(đã tìm trong Hyperlink nhưng không có đường link dẫn đến macro)
Cảm ơn các bạn nhiều!
Dùng sự kiện trong sheets là được nhé bạn.Bạn lên
 

Lequocvan

Thành viên thường trực
Tham gia ngày
21 Tháng tám 2007
Bài viết
334
Được thích
117
Điểm
695
Nơi ở
Hai Bà Trưng, Hà Nội
Khi em chạy code msit81_3 có lúc báo lỗi script out of range có lúc không? Quan trọng hơn nữa là khi chạy xong vẫn thấy thiếu phần của tiền EUR ah!
Mong mọi người chỉ giúp!
Đây là đoạn code VBA, mà em mày mò mãi chưa ra ah
Sub msit81_3()
''Dung Dictionary tong hop theo DP_TypeCode
Sheets("msit81_DP").Select
Dim Dic As Object
Dim iRow As Long, I As Long
Dim Arr() As Variant, VungDuLieu As Variant
With Sheets("BaoCaoTheoMSIT81")
.Range("A7:AR45").ClearContents '''''''''''''''''''''''''''''Tu dong 7 den dong 45
End With
With Sheets("msit81_DP")
Set Dic = CreateObject("Scripting.Dictionary")
VungDuLieu = Range("A1", Range("A1").End(xlToRight).End(xlDown).Address).Value '65536 '1048576
ReDim Arr(1 To UBound(VungDuLieu, 1), 1 To 29)

For iRow = 1 To UBound(VungDuLieu, 1)
j = j + 1
If Not IsEmpty(VungDuLieu(iRow, 5)) And Not Dic.Exists(VungDuLieu(iRow, 5)) Then
I = I + 1
Dic.Add VungDuLieu(iRow, 5), I
Arr(I, 1) = VungDuLieu(iRow, 5) 'Arr(I,1): DPCode
If VungDuLieu(iRow, 10) = "USD" Then '''''''''''''''''''''''''voi loai tien USD
If VungDuLieu(iRow, 1) = "00" Then
Arr(I, 2) = VungDuLieu(iRow, 11)
ElseIf VungDuLieu(iRow, 1) = "03" Then
Arr(I, 5) = VungDuLieu(iRow, 11)
ElseIf VungDuLieu(iRow, 1) = "04" Then
Arr(I, 8) = VungDuLieu(iRow, 11)
ElseIf VungDuLieu(iRow, 1) = "07" Then
Arr(I, 11) = VungDuLieu(iRow, 11)
ElseIf VungDuLieu(iRow, 1) = "09" Then
Arr(I, 14) = VungDuLieu(iRow, 11)
ElseIf VungDuLieu(iRow, 1) = "10" Then
Arr(I, 17) = VungDuLieu(iRow, 11)
ElseIf VungDuLieu(iRow, 1) = " " Then
Arr(I, 20) = VungDuLieu(iRow, 11)
ElseIf VungDuLieu(iRow, 1) = "05" Then
Arr(I, 23) = VungDuLieu(iRow, 11)
ElseIf VungDuLieu(iRow, 1) = "01" Then
Arr(I, 26) = VungDuLieu(iRow, 11)
ElseIf VungDuLieu(iRow, 1) = "02" Then
Arr(I, 29) = VungDuLieu(iRow, 11)
ElseIf VungDuLieu(iRow, 1) = "06" Then
Arr(I, 32) = VungDuLieu(iRow, 11)
ElseIf VungDuLieu(iRow, 1) = "08" Then
Arr(I, 35) = VungDuLieu(iRow, 11)
End If
ElseIf VungDuLieu(iRow, 10) = "VND" Then
If VungDuLieu(iRow, 1) = "00" Then
Arr(I, 3) = VungDuLieu(iRow, 11)
ElseIf VungDuLieu(iRow, 1) = "03" Then
Arr(I, 6) = VungDuLieu(iRow, 11)
ElseIf VungDuLieu(iRow, 1) = "04" Then
Arr(I, 9) = VungDuLieu(iRow, 11)
ElseIf VungDuLieu(iRow, 1) = "07" Then
Arr(I, 12) = VungDuLieu(iRow, 11)
ElseIf VungDuLieu(iRow, 1) = "09" Then
Arr(I, 15) = VungDuLieu(iRow, 11)
ElseIf VungDuLieu(iRow, 1) = "10" Then
Arr(I, 18) = VungDuLieu(iRow, 11)
ElseIf VungDuLieu(iRow, 1) = " " Then
Arr(I, 21) = VungDuLieu(iRow, 11)
ElseIf VungDuLieu(iRow, 1) = "05" Then
Arr(I, 24) = VungDuLieu(iRow, 11)
ElseIf VungDuLieu(iRow, 1) = "01" Then
Arr(I, 27) = VungDuLieu(iRow, 11)
ElseIf VungDuLieu(iRow, 1) = "02" Then
Arr(I, 30) = VungDuLieu(iRow, 11)
ElseIf VungDuLieu(iRow, 1) = "06" Then
Arr(I, 33) = VungDuLieu(iRow, 11)
ElseIf VungDuLieu(iRow, 1) = "08" Then
Arr(I, 36) = VungDuLieu(iRow, 11)
End If
ElseIf VungDuLieu(iRow, 10) = "EUR" Then
If VungDuLieu(iRow, 1) = "00" Then
Arr(I, 4) = VungDuLieu(iRow, 11)
ElseIf VungDuLieu(iRow, 1) = "03" Then
Arr(I, 7) = VungDuLieu(iRow, 11)
ElseIf VungDuLieu(iRow, 1) = "04" Then
Arr(I, 10) = VungDuLieu(iRow, 11)
ElseIf VungDuLieu(iRow, 1) = "07" Then
Arr(I, 13) = VungDuLieu(iRow, 11)
ElseIf VungDuLieu(iRow, 1) = "09" Then
Arr(I, 16) = VungDuLieu(iRow, 11)
ElseIf VungDuLieu(iRow, 1) = "10" Then
Arr(I, 19) = VungDuLieu(iRow, 11)
ElseIf VungDuLieu(iRow, 1) = " " Then
Arr(I, 22) = VungDuLieu(iRow, 11)
ElseIf VungDuLieu(iRow, 1) = "05" Then
Arr(I, 25) = VungDuLieu(iRow, 11)
ElseIf VungDuLieu(iRow, 1) = "01" Then
Arr(I, 28) = VungDuLieu(iRow, 11)
ElseIf VungDuLieu(iRow, 1) = "02" Then
Arr(I, 31) = VungDuLieu(iRow, 11)
ElseIf VungDuLieu(iRow, 1) = "06" Then
Arr(I, 34) = VungDuLieu(iRow, 11)
ElseIf VungDuLieu(iRow, 1) = "08" Then
Arr(I, 37) = VungDuLieu(iRow, 11)
End If
End If
Else
If VungDuLieu(iRow, 10) = "USD" Then
If VungDuLieu(iRow, 1) = "00" Then
Arr(Dic.Item(VungDuLieu(iRow, 5)), 2) = Arr(Dic.Item(VungDuLieu(iRow, 5)), 2) + VungDuLieu(iRow, 11)
ElseIf VungDuLieu(iRow, 1) = "03" Then
Arr(Dic.Item(VungDuLieu(iRow, 5)), 5) = Arr(Dic.Item(VungDuLieu(iRow, 5)), 5) + VungDuLieu(iRow, 11)
ElseIf VungDuLieu(iRow, 1) = "04" Then
Arr(Dic.Item(VungDuLieu(iRow, 5)), 8) = Arr(Dic.Item(VungDuLieu(iRow, 5)), 8) + VungDuLieu(iRow, 11)
ElseIf VungDuLieu(iRow, 1) = "07" Then
Arr(Dic.Item(VungDuLieu(iRow, 5)), 11) = Arr(Dic.Item(VungDuLieu(iRow, 5)), 11) + VungDuLieu(iRow, 11)
ElseIf VungDuLieu(iRow, 1) = "09" Then
Arr(Dic.Item(VungDuLieu(iRow, 5)), 14) = Arr(Dic.Item(VungDuLieu(iRow, 5)), 14) + VungDuLieu(iRow, 11)
ElseIf VungDuLieu(iRow, 1) = "10" Then
Arr(Dic.Item(VungDuLieu(iRow, 5)), 17) = Arr(Dic.Item(VungDuLieu(iRow, 5)), 17) + VungDuLieu(iRow, 11)
ElseIf VungDuLieu(iRow, 1) = " " Then
Arr(Dic.Item(VungDuLieu(iRow, 5)), 20) = Arr(Dic.Item(VungDuLieu(iRow, 5)), 20) + VungDuLieu(iRow, 11)
ElseIf VungDuLieu(iRow, 1) = "05" Then
Arr(Dic.Item(VungDuLieu(iRow, 5)), 23) = Arr(Dic.Item(VungDuLieu(iRow, 5)), 23) + VungDuLieu(iRow, 11)
ElseIf VungDuLieu(iRow, 1) = "01" Then
Arr(Dic.Item(VungDuLieu(iRow, 5)), 26) = Arr(Dic.Item(VungDuLieu(iRow, 5)), 26) + VungDuLieu(iRow, 11)
ElseIf VungDuLieu(iRow, 1) = "02" Then
Arr(Dic.Item(VungDuLieu(iRow, 5)), 29) = Arr(Dic.Item(VungDuLieu(iRow, 5)), 29) + VungDuLieu(iRow, 11)
ElseIf VungDuLieu(iRow, 1) = "06" Then
Arr(Dic.Item(VungDuLieu(iRow, 5)), 32) = Arr(Dic.Item(VungDuLieu(iRow, 5)), 32) + VungDuLieu(iRow, 11)
ElseIf VungDuLieu(iRow, 1) = "08" Then
Arr(Dic.Item(VungDuLieu(iRow, 5)), 35) = Arr(Dic.Item(VungDuLieu(iRow, 5)), 35) + VungDuLieu(iRow, 11)
End If
ElseIf VungDuLieu(iRow, 10) = "VND" Then
If VungDuLieu(iRow, 1) = "00" Then
Arr(Dic.Item(VungDuLieu(iRow, 5)), 3) = Arr(Dic.Item(VungDuLieu(iRow, 5)), 3) + VungDuLieu(iRow, 11)
ElseIf VungDuLieu(iRow, 1) = "03" Then
Arr(Dic.Item(VungDuLieu(iRow, 5)), 6) = Arr(Dic.Item(VungDuLieu(iRow, 5)), 6) + VungDuLieu(iRow, 11)
ElseIf VungDuLieu(iRow, 1) = "04" Then
Arr(Dic.Item(VungDuLieu(iRow, 5)), 9) = Arr(Dic.Item(VungDuLieu(iRow, 5)), 9) + VungDuLieu(iRow, 11)
ElseIf VungDuLieu(iRow, 1) = "07" Then
Arr(Dic.Item(VungDuLieu(iRow, 5)), 12) = Arr(Dic.Item(VungDuLieu(iRow, 5)), 12) + VungDuLieu(iRow, 11)
ElseIf VungDuLieu(iRow, 1) = "09" Then
Arr(Dic.Item(VungDuLieu(iRow, 5)), 15) = Arr(Dic.Item(VungDuLieu(iRow, 5)), 15) + VungDuLieu(iRow, 11)
ElseIf VungDuLieu(iRow, 1) = "10" Then
Arr(Dic.Item(VungDuLieu(iRow, 5)), 18) = Arr(Dic.Item(VungDuLieu(iRow, 5)), 18) + VungDuLieu(iRow, 11)
ElseIf VungDuLieu(iRow, 1) = " " Then
Arr(Dic.Item(VungDuLieu(iRow, 5)), 21) = Arr(Dic.Item(VungDuLieu(iRow, 5)), 21) + VungDuLieu(iRow, 11)
ElseIf VungDuLieu(iRow, 1) = "05" Then
Arr(Dic.Item(VungDuLieu(iRow, 5)), 24) = Arr(Dic.Item(VungDuLieu(iRow, 5)), 24) + VungDuLieu(iRow, 11)
ElseIf VungDuLieu(iRow, 1) = "01" Then
Arr(Dic.Item(VungDuLieu(iRow, 5)), 27) = Arr(Dic.Item(VungDuLieu(iRow, 5)), 27) + VungDuLieu(iRow, 11)
ElseIf VungDuLieu(iRow, 1) = "02" Then
Arr(Dic.Item(VungDuLieu(iRow, 5)), 30) = Arr(Dic.Item(VungDuLieu(iRow, 5)), 30) + VungDuLieu(iRow, 11)
ElseIf VungDuLieu(iRow, 1) = "06" Then
Arr(Dic.Item(VungDuLieu(iRow, 5)), 33) = Arr(Dic.Item(VungDuLieu(iRow, 5)), 33) + VungDuLieu(iRow, 11)
ElseIf VungDuLieu(iRow, 1) = "08" Then
Arr(Dic.Item(VungDuLieu(iRow, 5)), 36) = Arr(Dic.Item(VungDuLieu(iRow, 5)), 36) + VungDuLieu(iRow, 11)
End If
ElseIf VungDuLieu(iRow, 10) = "EUR" Then
If VungDuLieu(iRow, 1) = "00" Then
Arr(Dic.Item(VungDuLieu(iRow, 5)), 4) = Arr(Dic.Item(VungDuLieu(iRow, 5)), 4) + VungDuLieu(iRow, 11)
ElseIf VungDuLieu(iRow, 1) = "03" Then
Arr(Dic.Item(VungDuLieu(iRow, 5)), 7) = Arr(Dic.Item(VungDuLieu(iRow, 5)), 7) + VungDuLieu(iRow, 11)
ElseIf VungDuLieu(iRow, 1) = "04" Then
Arr(Dic.Item(VungDuLieu(iRow, 5)), 10) = Arr(Dic.Item(VungDuLieu(iRow, 5)), 10) + VungDuLieu(iRow, 11)
ElseIf VungDuLieu(iRow, 1) = "07" Then
Arr(Dic.Item(VungDuLieu(iRow, 5)), 13) = Arr(Dic.Item(VungDuLieu(iRow, 5)), 13) + VungDuLieu(iRow, 11)
ElseIf VungDuLieu(iRow, 1) = "09" Then
Arr(Dic.Item(VungDuLieu(iRow, 5)), 16) = Arr(Dic.Item(VungDuLieu(iRow, 5)), 16) + VungDuLieu(iRow, 11)
ElseIf VungDuLieu(iRow, 1) = "10" Then
Arr(Dic.Item(VungDuLieu(iRow, 5)), 19) = Arr(Dic.Item(VungDuLieu(iRow, 5)), 19) + VungDuLieu(iRow, 11)
ElseIf VungDuLieu(iRow, 1) = " " Then
Arr(Dic.Item(VungDuLieu(iRow, 5)), 22) = Arr(Dic.Item(VungDuLieu(iRow, 5)), 22) + VungDuLieu(iRow, 11)
ElseIf VungDuLieu(iRow, 1) = "05" Then
Arr(Dic.Item(VungDuLieu(iRow, 5)), 25) = Arr(Dic.Item(VungDuLieu(iRow, 5)), 25) + VungDuLieu(iRow, 11)
ElseIf VungDuLieu(iRow, 1) = "01" Then
Arr(Dic.Item(VungDuLieu(iRow, 5)), 28) = Arr(Dic.Item(VungDuLieu(iRow, 5)), 28) + VungDuLieu(iRow, 11)
ElseIf VungDuLieu(iRow, 1) = "02" Then
Arr(Dic.Item(VungDuLieu(iRow, 5)), 31) = Arr(Dic.Item(VungDuLieu(iRow, 5)), 31) + VungDuLieu(iRow, 11)
ElseIf VungDuLieu(iRow, 1) = "06" Then
Arr(Dic.Item(VungDuLieu(iRow, 5)), 34) = Arr(Dic.Item(VungDuLieu(iRow, 5)), 34) + VungDuLieu(iRow, 11)
ElseIf VungDuLieu(iRow, 1) = "08" Then
Arr(Dic.Item(VungDuLieu(iRow, 5)), 37) = Arr(Dic.Item(VungDuLieu(iRow, 5)), 37) + VungDuLieu(iRow, 11)
End If
End If
End If
Next iRow
End With

Sheets("BaoCaoTheoMSIT81").Select
With Sheets("BaoCaoTheoMSIT81")
.Range("B9").Resize(I, 37).Value = Arr 'dong nay de xuat gtri mang Arr ra
.Range("C7").Value = "HoiSo-TienGui"
.Range("C7:E7").Merge
.Range("F7").Value = "PGD03-TienGui"
.Range("F7:H7").Merge
.Range("I7").Value = "PGD04-TienGui"
.Range("I7:K7").Merge
.Range("L7").Value = "PGD07-TienGui"
.Range("L7:N7").Merge
.Range("O7").Value = "PGD09-TienGui"
.Range("O7:Q7").Merge
.Range("R7").Value = "PGD10-TienGui"
.Range("R7:T7").Merge
.Range("U7").Value = "IB-TienGui"
.Range("U7:W7").Merge
.Range("X7").Value = "PGD05-TienGui"
.Range("X7:Z7").Merge
.Range("AA7").Value = "PGD01-TienGui"
.Range("AA7:AC7").Merge
.Range("AD7").Value = "PGD02-TienGui"
.Range("AD7:AF7").Merge
.Range("AG7").Value = "PGD06-TienGui"
.Range("AG7:AI7").Merge
.Range("AJ7").Value = "PGD08-TienGui"
.Range("AJ7:AL7").Merge
.Range("C9").Value = "USD"
.Range("D9").Value = "VND"
.Range("E9").Value = "EUR"
.Range("C9:E9").Copy
.Range("F9:AL9").Select
.Paste
.Range("A9").Value = "STT"
.Range("B9").Value = "DPcode"
End With
Application.CutCopyMode = False
Set Dic = Nothing

Sheets("BaoCaoTheoMSIT81").Range("A7:AL" & Cells(Rows.count, 2).End(xlUp).Row).Select
With Selection
.Borders(xlDiagonalDown).LineStyle = xlNone
.Borders(xlDiagonalUp).LineStyle = xlNone
.Borders(xlEdgeLeft).Weight = xlMedium
.Borders(xlEdgeTop).Weight = xlMedium
.Borders(xlEdgeBottom).Weight = xlMedium
.Borders(xlEdgeRight).Weight = xlMedium
.Borders(xlInsideVertical).Weight = xlThin
.Borders(xlInsideHorizontal).Weight = xlThin
End With

Sheets("BaoCaoTheoMSIT81").Range("B8:B" & Cells(Rows.count, 2).End(xlUp).Row).Select
With Selection
.ColumnWidth = 4.71
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.WrapText = True
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
End With

'Sap xep thu tu cot DPcode
DongCuoiCuaCot = Cells(Rows.count, 2).End(xlUp).Row
ActiveWorkbook.Worksheets("BaoCaoTheoMSIT81").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("BaoCaoTheoMSIT81").Sort.SortFields.Add key:=Range( _
"B9:B" & DongCuoiCuaCot), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
xlSortNormal
With ActiveWorkbook.Worksheets("BaoCaoTheoMSIT81").Sort
.SetRange Range("B9:AL" & DongCuoiCuaCot)
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With

Range("C10", Range("AL" & DongCuoiCuaCot)).Select
Selection.NumberFormat = "#,##0.00"

Columns("A:AL").AutoFit
Sheets("BaoCaoTheoMSIT81").Range("A8").Select
Application.CutCopyMode = False
End Sub
 
Top Bottom