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

Liên hệ QC

maytinhvp01

Thành viên thường trực
Tham gia
27/7/13
Bài viết
390
Được thích
179
Mình muốn nhờ giải thich câu lệnh " If Ran.Cells(d, c) > max Then max = Ran.Cells(d, c) "
trong ví du:
Public Function LonNhat(Ran As Range)
Dim max As Double, v As Integer, d As Integer, c As Integer
max = Ran.Cells(1, 1)
For d = 1 To Ran.Rows.Count
For c = 1 To Ran.Columns.Count
If Ran.Cells(d, c) > max Then max = Ran.Cells(d, c)
Next c
Next d
v = Tim(max, Ran)
LonNhat = max
End Function
-------------------------------------------------------
[INFO1]Thông báo:
Vì topic này:
http://www.giaiphapexcel.com/forum/...ải-thích-các-code-đề-nghị-các-bạn-gửi-vào-đây
đã quá dài nên BQT đóng lại.
Nay tôi mở topic mới với cùng chủ đề: GIẢI THÍCH NHỮNG THẮC MẮC VỀ CODE
Các bạn nếu có nhu cầu giải thích code, vui lòng post tại đây nhé
NDU96081631

[/INFO1]
 
Chỉnh sửa lần cuối bởi điều hành viên:
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
 
Upvote 0
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:
Upvote 0
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
 
Upvote 0
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
 
Upvote 0
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:
Upvote 0
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
 
Upvote 0
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
 
Upvote 0
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

  • Test.xlsm
    74.5 KB · Đọc: 4
Upvote 0
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

  • test_in.xlsx
    56.7 KB · Đọc: 3
  • code in hoang loat.zip
    935 bytes · Đọc: 5
  • HELP - CODE PRINT OT - 26Aug2020.xlsm
    155.6 KB · Đọc: 3
Lần chỉnh sửa cuối:
Upvote 0
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
 
Upvote 0
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)
 
Upvote 0
Lần chỉnh sửa cuối:
Upvote 0
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!
 

File đính kèm

  • msit81-DepositListReport-USD-VND-EUR-202007_____hoi GPE.xlsb
    393.1 KB · Đọc: 5
Upvote 0
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!
 
Upvote 0
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
 
Upvote 0
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
 
Upvote 0
Nhờ cao nhân giúp mình làm sao có thể chỉnh code để có thể add in hàng loạt file như file đính kèm.
Mọi người xem file đính kèm cho dễ hiểu ạ.
Mình cần in tất cả các CODE trong cột S;
Lấy cell O4 làm tiêu chuẩn đầu tiên cho giá trị nhập (thực ra là chọn cell nào cũng được), miễn có mã nhân viên = B1 để lấy đó làm giá trị đầu tiên. Nếu chạy từng mã như vậy thì IN hàng loạt ok nhưng quá tốn giấy nên mình muốn chạy một lúc 7 cột thì có cách nào để in được và không bị trùng mã khi lấy dữ liệu.

Thanks!
Mã:
Sub inhangloat()
   
    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, i, t 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

  • HELP - IN PL.xlsx
    46.2 KB · Đọc: 6
Lần chỉnh sửa cuối:
Upvote 0
Chào mọi người ạ
Để xóa một cell đang chọn thì chúng ta viết code như sau:
Mã:
Sub Xoa()
ActiveCell.Select
Selection.ClearContents
End Sub
Vậy nếu đang chọn một vùng range bất kỳ và muốn xóa thì code như thế nào ạ (Range này có thể thay đổi)
Em cảm ơn
 
Upvote 0
Web KT
Back
Top Bottom