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

Liên hệ QC
maytinhvp01

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ắp xếp theo thời gian sắp xếp theo bầu chọn
moihocvba đã viết:
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!
Nhấp chuột vào đây để mở rộng...

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

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

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
vova2209 đã viết:
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
Nhấp chuột vào đây để mở rộng...
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

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
hoanglocphat đã viết:
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!
Nhấp chuột vào đây để mở rộng...
Dùng sự kiện trong sheets là được nhé bạn.Bạn lên
 
Upvote 0
Lequocvan đã viết:
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!
Nhấp chuột vào đây để mở rộng...
Đâ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

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
Trên bàn phím có phím Delete đó bạn, bấm vô.
 
Upvote 0
Mọi người ơi xem dùm code này bị lỗi gì và nên xử lý thế nào. Đơn thuần là mình muốn cột 21 = cột 15 - cột 4
Mã: 
Sub Update_Data()
Dim sArr(), i As Long, j As Long, Dic As Object, ResignedList()
Set Dic = CreateObject("scripting.dictionary")
With Sheets("Resigned List")
   ResignedList = .Range("A6", .Range("A" & Rows.Count).End(3)).Resize(, 10).Value
End With
For i = 1 To UBound(ResignedList)
   If Not Dic.exists(ResignedList(i, 2)) Then
      Dic.Add ResignedList(i, 2), ResignedList(i, 7)
   Else
      MsgBox "Duplicate " & ResignedList(i, 2)
   End If
Next
With Sheets("Candidates")
   sArr = .Range("A7", .Range("A" & Rows.Count).End(3)).Resize(, 21).Value
   For i = 1 To UBound(sArr)
      For j = 1 To UBound(sArr, 2)
         sArr(i, j) = Application.Trim(sArr(i, j))
      Next
      If IsDate(sArr(i, 4)) Then
         sArr(i, 18) = MonthName(Month(sArr(i, 4)), True)
         sArr(i, 19) = Year(sArr(i, 4))
      End If
      If Dic.exists(sArr(i, 5)) Then
         sArr(i, 15) = Dic.Item(sArr(i, 5))
         sArr(i, 14) = "Resigned"
         If IsDate(sArr(i, 4)) Then
            sArr(i, 21) = sArr(i, 15) - sArr(i, 4)
            If sArr(i, 21) < 4 Then
               sArr(i, 20) = "A"
            ElseIf sArr(i, 21) < 8 Then
               sArr(i, 20) = "B"
            ElseIf sArr(i, 21) < 31 Then
               sArr(i, 20) = "C"
            ElseIf sArr(i, 21) > 30 Then
               sArr(i, 20) = "D"
            End If
         End If
      End If
   Next
   .[A7].Resize(UBound(sArr), UBound(sArr, 2)) = sArr
End With
End Sub
 

File đính kèm

Upvote 0
quanghai1969 đã viết:
Mọi người ơi xem dùm code này bị lỗi gì và nên xử lý thế nào. Đơn thuần là mình muốn cột 21 = cột 15 - cột 4
Mã: 
Sub Update_Data()
Dim sArr(), i As Long, j As Long, Dic As Object, ResignedList()
Set Dic = CreateObject("scripting.dictionary")
With Sheets("Resigned List")
   ResignedList = .Range("A6", .Range("A" & Rows.Count).End(3)).Resize(, 10).Value
End With
For i = 1 To UBound(ResignedList)
   If Not Dic.exists(ResignedList(i, 2)) Then
      Dic.Add ResignedList(i, 2), ResignedList(i, 7)
   Else
      MsgBox "Duplicate " & ResignedList(i, 2)
   End If
Next
With Sheets("Candidates")
   sArr = .Range("A7", .Range("A" & Rows.Count).End(3)).Resize(, 21).Value
   For i = 1 To UBound(sArr)
      For j = 1 To UBound(sArr, 2)
         sArr(i, j) = Application.Trim(sArr(i, j))
      Next
      If IsDate(sArr(i, 4)) Then
         sArr(i, 18) = MonthName(Month(sArr(i, 4)), True)
         sArr(i, 19) = Year(sArr(i, 4))
      End If
      If Dic.exists(sArr(i, 5)) Then
         sArr(i, 15) = Dic.Item(sArr(i, 5))
         sArr(i, 14) = "Resigned"
         If IsDate(sArr(i, 4)) Then
            sArr(i, 21) = sArr(i, 15) - sArr(i, 4)
            If sArr(i, 21) < 4 Then
               sArr(i, 20) = "A"
            ElseIf sArr(i, 21) < 8 Then
               sArr(i, 20) = "B"
            ElseIf sArr(i, 21) < 31 Then
               sArr(i, 20) = "C"
            ElseIf sArr(i, 21) > 30 Then
               sArr(i, 20) = "D"
            End If
         End If
      End If
   Next
   .[A7].Resize(UBound(sArr), UBound(sArr, 2)) = sArr
End With
End Sub
Nhấp chuột vào đây để mở rộng...
Ai lại cắt vô tội vạ như thế :D
Rich (BB code): 
      For j = 1 To UBound(sArr, 2)
        If TypeName(sArr(i, j)) = "String" Then sArr(i, j) = Application.Trim(sArr(i, j))
      Next
 
Upvote 0
quanghai1969 đã viết:
Mọi người ơi xem dùm code này bị lỗi gì và nên xử lý thế nào. Đơn thuần là mình muốn cột 21 = cột 15 - cột 4
Mã: 
Sub Update_Data()
Dim sArr(), i As Long, j As Long, Dic As Object, ResignedList()
Set Dic = CreateObject("scripting.dictionary")
With Sheets("Resigned List")
   ResignedList = .Range("A6", .Range("A" & Rows.Count).End(3)).Resize(, 10).Value
End With
For i = 1 To UBound(ResignedList)
   If Not Dic.exists(ResignedList(i, 2)) Then
      Dic.Add ResignedList(i, 2), ResignedList(i, 7)
   Else
      MsgBox "Duplicate " & ResignedList(i, 2)
   End If
Next
With Sheets("Candidates")
   sArr = .Range("A7", .Range("A" & Rows.Count).End(3)).Resize(, 21).Value
   For i = 1 To UBound(sArr)
      For j = 1 To UBound(sArr, 2)
         sArr(i, j) = Application.Trim(sArr(i, j))
      Next
      If IsDate(sArr(i, 4)) Then
         sArr(i, 18) = MonthName(Month(sArr(i, 4)), True)
         sArr(i, 19) = Year(sArr(i, 4))
      End If
      If Dic.exists(sArr(i, 5)) Then
         sArr(i, 15) = Dic.Item(sArr(i, 5))
         sArr(i, 14) = "Resigned"
         If IsDate(sArr(i, 4)) Then
            sArr(i, 21) = sArr(i, 15) - sArr(i, 4)
            If sArr(i, 21) < 4 Then
               sArr(i, 20) = "A"
            ElseIf sArr(i, 21) < 8 Then
               sArr(i, 20) = "B"
            ElseIf sArr(i, 21) < 31 Then
               sArr(i, 20) = "C"
            ElseIf sArr(i, 21) > 30 Then
               sArr(i, 20) = "D"
            End If
         End If
      End If
   Next
   .[A7].Resize(UBound(sArr), UBound(sArr, 2)) = sArr
End With
End Sub
Nhấp chuột vào đây để mở rộng...
Em chỉnh lại thành sArr(i, 21) = CDate(sArr(i, 15)) - CDate(sArr(i, 4)) thì thấy hết lỗi, không biết đúng không nữa anh ơi
 
Upvote 0
thnghiachau đã viết:
Em chỉnh lại thành sArr(i, 21) = CDate(sArr(i, 15)) - CDate(sArr(i, 4)) thì thấy hết lỗi, không biết đúng không nữa anh ơi
Nhấp chuột vào đây để mở rộng...
Mình cũng test đủ kiểu, CDate, rồi cả DateValue cũng không ăn thua. Nó hết lỗi nhưng kết quả ra không đúng. Tại dòng đầu nó cứ cho kết quả là Aug
 
Upvote 0
huuthang_bd đã viết:
Ai lại cắt vô tội vạ như thế :D
Rich (BB code): 
      For j = 1 To UBound(sArr, 2)
        If TypeName(sArr(i, j)) = "String" Then sArr(i, j) = Application.Trim(sArr(i, j))
      Next
Nhấp chuột vào đây để mở rộng...
À giờ mình hiểu rồi. Sau khi trim thì dữ liệu ngày giờ sẽ bị chuyển sang Text.

Cảm ơn sự giải đáp của HuuThang, đã cho mình một kiến thức mới
 
Upvote 0
Bạn phải đăng nhập hoặc đăng ký để trả lời bài viết tại đây.
Web KT

Bài viết mới nhất

dangtuan1212
Mình cần hỗ trợ in excel 2 mặt căn lề trái phải theo trang chẵn lẻ
Trả lời
0
Đọc
14
dangtuan1212
dangtuan1212
C
Code Set password File Excel
Trả lời
2
Đọc
85
Cúc Hr
C
ongke0711
  • Question Question
Tải hóa đơn điện tử (https://hoadondientu.gdt.gov.vn/) Excel Vba
    • Thích
    • Yêu thích
    • Cảm ơn
14 15 16
Trả lời
302
Đọc
20K
bimbebeo
bimbebeo
X
Tự động giãn dòng và ẩn các dòng bị bỏ trống
Trả lời
7
Đọc
293
HUONGHCKT
H
T
Xin giúp em copy cột C ở tất cả các sheet vào file import_template. Em cảm ơn ạ.
Trả lời
3
Đọc
96
yaaasoo01
Y
tutepp
Lỗi không mở được file Excel, chỉ mở được khi dùng Ultraview
Trả lời
3
Đọc
63
hvnhpro
H
T
Cố định các dòng merger cell để khi in không bị ẩn mất nội dung khi dùng Autofit row height
Trả lời
1
Đọc
44
yaaasoo01
Y
HeSanbi
  • Đã giải quyết
HÀM FITROW - Co giãn dòng tự động tối ưu nhất cho Excel v2.43 (*14/10/2024)
    • Thích
    • Yêu thích
2 3
Trả lời
53
Đọc
22K
minhminh040499
minhminh040499
GPE-Trợ Lý
[GPE] TALK SHOW NHỮNG ĐIỀU NHỎ TÁC DỤNG LỚN TRONG PIVOT TABLE
    • Thích
Trả lời
1
Đọc
190
GPE-Trợ Lý
GPE-Trợ Lý
1
Phát triển một VBE trong Delphi để tạo một cửa sổ công cụ.
Trả lời
8
Đọc
189
nguyendang95
N
Hoàng Trọng Nghĩa
  • Suggestion Suggestion
Tặng các bạn file "QUAY SỐ TRÚNG THƯỞNG"
    • Thích
Trả lời
9
Đọc
4K
anthanh32
anthanh32
KTS NGUYEN DU
Các bác có biết chỉnh mục trống này về dạng word cơ bản không ạ.
Trả lời
5
Đọc
150
KTS NGUYEN DU
KTS NGUYEN DU
giaiphap
Chia sẻ cách tạo gợi ý cho hàm trong Excel bằng thư viện ExcelDna.
    • Thích
    • Yêu thích
    • Cảm ơn
Trả lời
6
Đọc
2K
Phương Nguyễn 89
Phương Nguyễn 89
hahuykhuong
  • Question Question
link file pdf hóa đơn bằng vba
Trả lời
3
Đọc
172
hahuykhuong
hahuykhuong
Manhhung90
  • Question Question
Xin giúp chuyển dữ liệu từ cột dọc sang hàng ngang theo điều kiện
    • Buồn
Trả lời
10
Đọc
255
Manhhung90
Manhhung90
M
  • Question Question
Code VBA tìm mã kiện gỗ còn tồn kho
Trả lời
7
Đọc
314
BuiQuangThuan
B
HeSanbi
  • Đã giải quyết
ExplorerXL - Quản lý thư mục với Excel: tìm, đổi tên, sao chép, di chuyển và xóa
    • Thích
    • Yêu thích
    • Cảm ơn
3 4 5
Trả lời
80
Đọc
16K
ngochienbmt
N
T
cách viết hàm if
Trả lời
4
Đọc
187
VetMini
V
GPE-Trợ Lý
KHÓA HỌC BỨT PHÁ KỸ NĂNG EXCEL
    • Thích
    • Yêu thích
Trả lời
2
Đọc
946
nguyentnct
N
N
  • Question Question
Cần giúp rút gọn code vba
Trả lời
8
Đọc
288
VetMini
V
Xem thêm…

Thành viên có số lượng bài viết cao nhất tháng

Thành viên có điểm tương tác cao nhất tháng

Đếm ngược thời gian

000
Ngày
00
Giờ
00
phút
00
giây
Chúc mừng năm mới
Back
Top Bottom