Chuyên mục xử lý, gỡ rối code VBA (2 người xem)

ndu96081631 · 24/9/13

Topic Những câu hỏi về code, xin giải thích các code... đã quá dài nên mình đóng nó lại và mở topic khác
Tất cả những bài viết liên quan đến việc nhờ giải thích, xử lý và gỡ rối code VBA, các bạn vui lòng đăng tại đây!
Cảm ơn

tanhoai2002 · 8/12/14

Các bạn giúp mình xem đoạn code này sao mình áp dụng vào bảng tính của mình chạy một thời gian nó nặng quá trời luôn

Sub NhapLieu()
'Sao Chep So Lieu
Application.ScreenUpdating = False
Dim i, N, k
Sheets("Design").Select
[N34].Formula = "=Counta(R[2]C[-3]:R[7]C[-3])"
k = Range("N34").Value
For i = 1 To k
Cod = Range("C4").Value
ngay = Range("D5").Value
Mac = Range("A8").Value
LXi = Range("C16").Value
Xi = Range("A30").Value
SA = Range("K17").Value
PP1 = Range("B30").Value
LPP1 = Range("C17").Value
Nuoc = Range("C30").Value
C = Range("D30").Value
M = Range("E30").Value
D1 = Range("F30").Value
D2 = Range("G30").Value
Sheets("Summary").Select
[B2].Formula = "=2*Counta(R[8]C:R[1001]C)-1"
N = Range("B2").Value
Range("A11").Select
ActiveCell.Offset(N, 1).Value = ngay
ActiveCell.Offset(N, 2).Value = Mac
ActiveCell.Offset(N, 5).Value = LXi
ActiveCell.Offset(N, 9).Value = Xi
ActiveCell.Offset(N, 10).Value = PP1
ActiveCell.Offset(N, 11).Value = C
ActiveCell.Offset(N, 12).Value = M
ActiveCell.Offset(N, 13).Value = D1
ActiveCell.Offset(N, 14).Value = D2
ActiveCell.Offset(N, 15).Value = Nuoc
ActiveCell.Offset(N, 16).Value = SA
ActiveCell.Offset(N, 17).Value = Cod
ActiveCell.Offset(N + 1, 10).Value = LPP1
Sheets("Design").Select
Range("A1:M30").Select
Range("A10").Select
Next
Application.ScreenUpdating = True
End Sub

nhờ các bạn giúp mình hiện giờ file của mình lên tới 7,5 G rùi mình cảm ơn nhiều nhiều

phihndhsp · 8/12/14

tanhoai2002 đã viết:
nhờ các bạn giúp mình hiện giờ file của mình lên tới 7,5 G rùi mình cảm ơn nhiều nhiều

file bạn 7.5G mà bạn mở lên và chạy được, có nghĩa là máy bạn thuộc dạng khủng rồi đó. nói gì thì nói, gởi file lên đi mọi người xem và giúp cho. Tôi thấy code trên cũng bình thường thôi mà

tanhoai2002 · 8/12/14

phihndhsp đã viết:
file bạn 7.5G mà bạn mở lên và chạy được, có nghĩa là máy bạn thuộc dạng khủng rồi đó. nói gì thì nói, gởi file lên đi mọi người xem và giúp cho. Tôi thấy code trên cũng bình thường thôi mà

minh ghi lộn 7519 Kb thôi. mình gửi filee xóa giữ lệu nhe!

tanhoai2002 · 8/12/14

Bạn ơi mình xó giữ liệu mà nó còn 4200kb nên ko tải lên dc

BaoTram1102 · 12/12/14

Chào mọi người!!
Mình có đọc một hướng dẫn về cách gán Add_in lên thanh Menu,mình đã chỉnh sửa đôi chút và đưa vào đó một đoạn mã lệnh để thực hiện Add_in này.tuy nhiên lại không đạt kết quả/

Mọi người ngó giùm mình xem lỗi ở đâu và chỉ mình cách khắc phục với nhé!!!

Cảm ơn nhiều!!!!!!!

Option Private Module
Sub AddMenu()
Dim cMenu1 As CommandBarControl
Dim cbMainMenuBar As CommandBar
Dim iHelpMenu As Integer
Dim cbcCutomMenu As CommandBarControl
Dim cbcSubMenu As CommandBarControl

Set cbMainMenuBar = Application.CommandBars("Worksheet Menu Bar")

iHelpMenu = cbMainMenuBar.Controls("Help").Index

Set cbcCutomMenu = cbMainMenuBar.Controls.Add(Type:=msoControlPopup, Before:=iHelpMenu)
cbcCutomMenu.Caption = "Tien ich mo rong"

With cbcSubMenu.Controls.Add(Type:=msoControlButton)
.Caption = "Bo Dau Tieng Viet"
.FaceId = 2109
Function bodau(ByVal sContent As String) As String
Dim i As Long
Dim intCode As Long
Dim sChar As String
Dim sConvert As String
bodau = AscW(sContent)

For i = 1 To Len(sContent)
sChar = Mid(sContent, i, 1)
If sChar <> "" Then
intCode = AscW(sChar)
End If
Select Case intCode
Case 273
sConvert = sConvert & "d"
Case 272
sConvert = sConvert & "D"
Case 224, 225, 226, 227, 259, 7841, 7843, 7845, 7847, 7849, 7851, 7853, 7855, 7857, 7859, 7861, 7863
sConvert = sConvert & "a"
Case 192, 193, 194, 195, 258, 7840, 7842, 7844, 7846, 7848, 7850, 7852, 7854, 7856, 7858, 7860, 7862
sConvert = sConvert & "A"
Case 232, 233, 234, 7865, 7867, 7869, 7871, 7873, 7875, 7877, 7879
sConvert = sConvert & "e"
Case 200, 201, 202, 7864, 7866, 7868, 7870, 7872, 7874, 7876, 7878
sConvert = sConvert & "E"
Case 236, 237, 297, 7881, 7883
sConvert = sConvert & "i"
Case 204, 205, 296, 7880, 7882
sConvert = sConvert & "I"
Case 242, 243, 244, 245, 417, 7885, 7887, 7889, 7891, 7893, 7895, 7897, 7899, 7901, 7903, 7905, 7907
sConvert = sConvert & "o"
Case 210, 211, 212, 213, 416, 7884, 7886, 7888, 7890, 7892, 7894, 7896, 7898, 7900, 7902, 7904, 7906
sConvert = sConvert & "O"
Case 249, 250, 361, 432, 7909, 7911, 7913, 7915, 7917, 7919, 7921
sConvert = sConvert & "u"
Case 217, 218, 360, 431, 7908, 7910, 7912, 7914, 7916, 7918, 7920
sConvert = sConvert & "U"
Case 253, 7923, 7925, 7927, 7929
sConvert = sConvert & "y"
Case 221, 7922, 7924, 7926, 7928
sConvert = sConvert & "Y"
Case Else
sConvert = sConvert & sChar
End Select
Next
bodau = sConvert
End Function

End With

Kiều Mạnh · 13/12/14

Mình đang tập viết một code tổng hợp dữ liệu nhiều file đóng theo Sheet. A,B,C,D vào file tổng hợp Mà gặp rắc rối chưa xử lý được xin úp lên đây nhờ các bạn trợ giúp
xin cảm ơn

PHP:

Sub TongHop_FileDong()
Application.ScreenUpdating = False
Dim FileName, SheetName, Path As String, Chk As Boolean
Dim i As Long, j As Long, Sh As Worksheets, Wb As Workbook
Path = ThisWorkbook.Path
FileName = Array("File1", "File2", "File3", "File4")
SheetName = Array("A", "B", "C", "D")
For i = 0 To UBound(FileName)
    For Each Wb In Workbooks
        If Wb.Name = FileName(i) Then Chk = True
    Next
    If Chk = False Then Workbooks.Open Path & "\" & FileName(i)
    With ActiveWorkbook
        For j = 0 To UBound(SheetName, 1)
            With ActiveSheet
                MsgBox SheetName(j)
                ''dang roi khuc nay
                'SheetName = Sh.Range("A2", Sh.[J65536].End(3)).Copy
                'Range("A65536").End(3).Offset(1).PasteSpecial 3
            End With
        Next
        .Close False
    End With
Next
Application.ScreenUpdating = True
End Sub

Quang_Hải · 13/12/14

kieu manh đã viết:

Mình đang tập viết một code tổng hợp dữ liệu nhiều file đóng theo Sheet. A,B,C,D vào file tổng hợp Mà gặp rắc rối chưa xử lý được xin úp lên đây nhờ các bạn trợ giúp
xin cảm ơn

PHP:

Sub TongHop_FileDong()
Application.ScreenUpdating = False
Dim FileName, SheetName, Path As String, Chk As Boolean
Dim i As Long, j As Long, Sh As Worksheets, Wb As Workbook
Path = ThisWorkbook.Path
FileName = Array("File1", "File2", "File3", "File4")
SheetName = Array("A", "B", "C", "D")
For i = 0 To UBound(FileName)
    For Each Wb In Workbooks
        If Wb.Name = FileName(i) Then Chk = True
    Next
    If Chk = False Then Workbooks.Open Path & "\" & FileName(i)
    With ActiveWorkbook
        For j = 0 To UBound(SheetName, 1)
            With ActiveSheet
                MsgBox SheetName(j)
                ''dang roi khuc nay
                'SheetName = Sh.Range("A2", Sh.[J65536].End(3)).Copy
                'Range("A65536").End(3).Offset(1).PasteSpecial 3
            End With
        Next
        .Close False
    End With
Next
Application.ScreenUpdating = True
End Sub

Nhắm mắt sửa code chay, chưa test nha

PHP:

Sub TongHop_FileDong()
Application.ScreenUpdating = False
Dim FileName, SheetName, Path As String, Chk As Boolean, Tam()
Dim i As Long, j As Long, Sh As Worksheets, Wb As Workbook
Path = ThisWorkbook.Path
FileName = Array("File1", "File2", "File3", "File4")
SheetName = Array("A", "B", "C", "D")
For i = 0 To UBound(FileName)
    For Each Wb In Workbooks
        If Wb.Name = FileName(i) Then Chk = True
    Next
    If Chk = False Then Workbooks.Open Path & "\" & FileName(i)
    With ActiveWorkbook
         With Sheets(SheetName(i))
             Tam = .Range("A2", .[J65536].End(3)).Value
         End With
        .Close False
    End With
    Range("A65536").End(3).Offset(1).Resize(UBound(Tam), 10) = Tam
Next
Application.ScreenUpdating = True
End Sub

Kiều Mạnh · 13/12/14

quanghai1969 đã viết:

Nhắm mắt sửa code chay, chưa test nha

PHP:

Sub TongHop_FileDong()
Application.ScreenUpdating = False
Dim FileName, SheetName, Path As String, Chk As Boolean, Tam()
Dim i As Long, j As Long, Sh As Worksheets, Wb As Workbook
Path = ThisWorkbook.Path
FileName = Array("File1", "File2", "File3", "File4")
SheetName = Array("A", "B", "C", "D")
For i = 0 To UBound(FileName)
    For Each Wb In Workbooks
        If Wb.Name = FileName(i) Then Chk = True
    Next
    If Chk = False Then Workbooks.Open Path & "\" & FileName(i)
    With ActiveWorkbook
         With Sheets(SheetName(i))
             Tam = .Range("A2", .[J65536].End(3)).Value
         End With
        .Close False
    End With
    Range("A65536").End(3).Offset(1).Resize(UBound(Tam), 10) = Tam
Next
Application.ScreenUpdating = True
End Sub

Vậy mà mò hoài hỏng ra...em đang tập VBA tổng hợp theo sheet chỉ định....lâu nay làm tùm lum thì được khi vào chi tiết thấy rối
xin cảm ơn

garj_cuong · 13/12/14

Option Explicit
Sub tonghop()
Application.ScreenUpdating = False
Dim sh As Worksheet, Arr(), i, Rng As Range, n, c, r
Sheet1.Range("A4", "GM150").ClearContents
For Each sh In Worksheets
If sh.Name <> "Tong Hop" Then
Arr = sh.Range("B6", sh.[G150].End(3)).Value
n = n + 1
r = Sheet1.[A150].End(3).Offset(1).Row
Sheet1.[A150].End(3).Offset(1) = n
Sheet1.[B150].End(3).Offset(1) = sh.[B3].Value
Sheet1.[C150].End(3).Offset(1) = sh.[G151].End(3).Value
For i = 1 To UBound(Arr)
If Arr(i, 1) <> "" Then
Set Rng = Sheet1.Rows("2:2").Find(Arr(i, 1), , , 1)
If Not Rng Is Nothing Then
c = Rng.Column
Sheet1.Cells(r, c) = Arr(i, 2)
Sheet1.Cells(r, c + 1) = Arr(i, 4)
Sheet1.Cells(r, c + 2) = Arr(i, 6)
End If
End If
Next
End If
Next
End Sub

Các Bác cho em hỏi tại sao viết code thì làm việc đến cột GM nhưng khi chạy thì code chỉ làm việc thực tế đến hết cột U?
Em mới chập chững học hỏi mong các bác giúp đỡ. Thanks!

Kiều Mạnh · 20/12/14

Mình đang tập viết code tổng hợp dữ liệu từ file đóng bằng mãng . kết quả lấy lên đúng như mong muốn nhưng khi mình thử thay đổi từ
SheetName = Array("A", "B", "C", "D") thành SheetName = Array("D", "C", "B", "A") lộn xộn như vậy thì chạy code báo lỗi chưa tìm ra được
nguyên nhân mong các bạn trợ giúp
xin cảm ơn

PHP:

Sub TH_Theo_FileSheet()
Application.ScreenUpdating = False
Dim FileName(), SheetName(), Path As String, Chk As Boolean
Dim i As Long, j As Long, tam(), WB As Workbook
Dim kq(1 To 65536, 1 To 10), ii As Long, k As Long
Path = ThisWorkbook.Path
FileName = Array("File1", "File2", "File3", "File4")
SheetName = Array("A", "B", "C", "D"): Rem Neu viet SheetName theo thu tu FileName thi dung
''SheetName = Array("D", "C", "A", "B"): Rem Neu dao nguoc D,C,A,B THI KET QUA SAI VA LOI CODE
Range("A2", [J65536].End(3)).ClearContents
For i = 0 To UBound(FileName)
    For Each WB In Workbooks
        If WB.Name = FileName(i) Then Chk = True
    Next
    If Chk = False Then Workbooks.Open Path & "\" & FileName(i)
    With ActiveWorkbook
        With Sheets(SheetName(i))
            tam = .Range("A2", .[J65536].End(3)).Value
        End With
        .Close False
        For ii = 1 To UBound(tam)
            k = k + 1
            For j = 1 To UBound(tam, 2)
                kq(k, j) = tam(ii, j)
            Next
        Next
    End With
Next
[A2].Resize(k, UBound(tam, 2)) = kq
Application.ScreenUpdating = True
End Sub

Quang_Hải · 20/12/14

kieu manh đã viết:
Mình đang tập viết code tổng hợp dữ liệu từ file đóng bằng mãng . kết quả lấy lên đúng như mong muốn nhưng khi mình thử thay đổi từ
SheetName = Array("A", "B", "C", "D") thành SheetName = Array("D", "C", "B", "A") lộn xộn như vậy thì chạy code báo lỗi chưa tìm ra được
nguyên nhân mong các bạn trợ giúp
xin cảm ơn

Tạm sửa thế này

PHP:

Sub TH_Theo_FileSheet()
On Error Resume Next
Application.ScreenUpdating = False
Dim FileName(), SheetName(), Path As String, Chk As Boolean
Dim i As Long, j As Long, tam(), WB As Workbook, sh
Dim kq(1 To 65536, 1 To 10), ii As Long, k As Long
Path = ThisWorkbook.Path
FileName = Array("File1", "File2", "File3", "File4")
SheetName = Array("D", "C", "A", "B")
Range("A2", [J65536].End(3)).ClearContents
For i = 0 To UBound(FileName)
    For Each WB In Workbooks
        If WB.Name = FileName(i) Then Chk = True
    Next
    If Chk = False Then Workbooks.Open Path & "\" & FileName(i)
   With ActiveWorkbook
       For Each sh In SheetName
         With .Sheets(sh)
           tam = .Range("A2", .[J65536].End(3)).Value
         End With
       Next
       .Close False
   End With
   For ii = 1 To UBound(tam)
       k = k + 1
       For j = 1 To UBound(tam, 2)
           kq(k, j) = tam(ii, j)
       Next
   Next
Next
[A2].Resize(k, UBound(tam, 2)) = kq
Application.ScreenUpdating = True
End Sub

thangbkhn · 20/12/14

Bac giup em voi:
Em muon copy cot (B, 3+i) của tất cả các file vào cột (e,3+i) của file Summary,

nho bác giúp em.

Các file o link.
https://drive.google.com/folderview?id=0B8obhl-iauNyd1RCdXpxSlVFN0k&usp=drive_web

Kiều Mạnh · 20/12/14

quanghai1969 đã viết:

Tạm sửa thế này

PHP:

Sub TH_Theo_FileSheet()
On Error Resume Next
Application.ScreenUpdating = False
Dim FileName(), SheetName(), Path As String, Chk As Boolean
Dim i As Long, j As Long, tam(), WB As Workbook, sh
Dim kq(1 To 65536, 1 To 10), ii As Long, k As Long
Path = ThisWorkbook.Path
FileName = Array("File1", "File2", "File3", "File4")
SheetName = Array("D", "C", "A", "B")
Range("A2", [J65536].End(3)).ClearContents
For i = 0 To UBound(FileName)
    For Each WB In Workbooks
        If WB.Name = FileName(i) Then Chk = True
    Next
    If Chk = False Then Workbooks.Open Path & "\" & FileName(i)
   With ActiveWorkbook
       For Each sh In SheetName
         With .Sheets(sh)
           tam = .Range("A2", .[J65536].End(3)).Value
         End With
       Next
       .Close False
   End With
   For ii = 1 To UBound(tam)
       k = k + 1
       For j = 1 To UBound(tam, 2)
           kq(k, j) = tam(ii, j)
       Next
   Next
Next
[A2].Resize(k, UBound(tam, 2)) = kq
Application.ScreenUpdating = True
End Sub

Vậy phải chạy thêm một vòng For Next và On Error Resume Next nữa thì mới ok
cảm ơn anh

hikaru0110 · 31/1/15

Xin các đại huynh chỉ với ạ, em mới học nên có dòng code ko hiểu mong mọi người giải đáp với ạ, em xin cảm ơn mọi người nhiều
Đây là dòng code em không hiểu ý nghĩa của nó là gì nên mọi người chỉ giúp em với : Worksheets("HistData").spnYear.Value = 2004
Nhất là cái spnYear ý, em không hiểu nó là gì, mong mọi người chỉ với ạ, em chạy thì vb nó báo là : Object doén't support this property or method

Kiều Mạnh · 31/1/15

hikaru0110 đã viết:
Xin các đại huynh chỉ với ạ, em mới học nên có dòng code ko hiểu mong mọi người giải đáp với ạ, em xin cảm ơn mọi người nhiều
Đây là dòng code em không hiểu ý nghĩa của nó là gì nên mọi người chỉ giúp em với : Worksheets("HistData").spnYear.Value = 2004
Nhất là cái spnYear ý, em không hiểu nó là gì, mong mọi người chỉ với ạ, em chạy thì vb nó báo là : Object doén't support this property or method

Úp cái file đó lên mình coi cho

hikaru0110 · 31/1/15

kieu manh đã viết:
Úp cái file đó lên mình coi cho

Cái này là code, nó nguyên cả 1 khối, thầy bắt về nhà tự tìm hiểu và làm bài trong đó ạ, nên ko có file mà chỉ có code tự đánh vào theo sách thôi ạ

Kiều Mạnh · 31/1/15

hikaru0110 đã viết:
Cái này là code, nó nguyên cả 1 khối, thầy bắt về nhà tự tìm hiểu và làm bài trong đó ạ, nên ko có file mà chỉ có code tự đánh vào theo sách thôi ạ

vậy code như thế nào úp lên mình coi nó xem có khủng lắm không nha

hikaru0110 · 31/1/15

kieu manh đã viết:
vậy code như thế nào úp lên mình coi nó xem có khủng lắm không nha

Em hiểu rồi, cái spnYear đấy là nút spin button, đây là code, nhưng mà em vẽ cái nút đấy ra rồi chạy vẫn báo lỗi

<Code>
Option Explicit
Option Base 1
Public i As Integer, j As Integer
Public HolSF(1 To 3, 1 To 4) As Variant
Public PerSF(1 To 2, 1 To 4) As Variant
Public RangSF(1 To 2, 1 To 4, 1 To 2) As Variant
Public StdDevMSE As Double, MeanMSE As Double

Sub Main() 'called from the Start button
Call ClearPrev

Worksheets("HistData").spnYear.Value = 2004
j = 0
i = 1

Do While j < 360
If Weekday(DateAdd("d", j, 1 / 1 / 2004), vbMonday) < 6 Then
With Range("HistDataStart")
.Offset(i, 0).Value = DateAdd("d", j, "1 / 1 / 2004")
.Offset(i, 0).Value = Month(DateAdd("d", j, 1 / 1 / 2004))
.Offset(i, 0).Value = Weekday(DateAdd("d", j, 1 / 1 / 2004), vbMonday)
End With
i = i + 1
End If
j = j + 1
Loop

Worksheets("HistData").Visible = True
Worksheets("Welcome").Visible = False
Range("A1").Select

End Sub
</Code>

0972767890 · 6/2/15

các anh cho em hỏi về private function marc1(bf0,n,radphi0,radphi)

em có đoạn code này từ trang nước ngoài.em muốn chuyển nó sang một ngôn ngữ khác.
các anh có thể giải thích cho em đoạn M = Marc1(bf0, n, RadPHI0, RadPHI) ma em gạch chân bên dưới ý nghĩa nó như thế nào được không ạ.như ở đây M sẽ lấy giá trị gì từ marc1.
e đang làm trong basic for androi không có kiểu như thế,có thể thay đổi bằng phương pháp tính toán nào khác đc k ạ
em xin cám ơn các anh

Function WGS84LL2North(PHI As Double, LAM As Double)
Dim a, b, e0, f0, n0, PHI0 As Double
a = 6378137
b = 6356752.3141
e0 = 500000
f0 = 0.9996
PHI0 = 0
n0 = 0

'Calculate LAM0 of the UTM zone which the user input Longitude is in
Dim PreZNum As Double
Dim ZNum As Integer
Dim LAM0 As Double
PreZNum = (180 + LAM) / 6 + 1
ZNum = Int(PreZNum)
LAM0 = -(183 - 6 * ZNum)

'Convert angle measures to radians
PI = 3.14159265358979
RadPHI = PHI * (PI / 180)
RadLAM = LAM * (PI / 180)
RadPHI0 = PHI0 * (PI / 180)
RadLAM0 = LAM0 * (PI / 180)

af0 = a * f0
bf0 = b * f0
e2 = ((af0 ^ 2) - (bf0 ^ 2)) / (af0 ^ 2)
n = (af0 - bf0) / (af0 + bf0)
nu = af0 / (Sqr(1 - (e2 * ((Sin(RadPHI)) ^ 2))))
rho = (nu * (1 - e2)) / (1 - (e2 * (Sin(RadPHI)) ^ 2))
eta2 = (nu / rho) - 1
p = RadLAM - RadLAM0

M = Marc1(bf0, n, RadPHI0, RadPHI)

I = M + n0
II = (nu / 2) * (Sin(RadPHI)) * (Cos(RadPHI))
III = ((nu / 24) * (Sin(RadPHI)) * ((Cos(RadPHI)) ^ 3)) * (5 - ((Tan(RadPHI)) ^ 2) + (9 * eta2))
IIIA = ((nu / 720) * (Sin(RadPHI)) * ((Cos(RadPHI)) ^ 5)) * (61 - (58 * ((Tan(RadPHI)) ^ 2)) + ((Tan(RadPHI)) ^ 4))

WGS84LL2North = I + ((p ^ 2) * II) + ((p ^ 4) * III) + ((p ^ 6) * IIIA)

End Function

Private Function Marc1(bf0, n, PHI0, PHI)
Marc1 = bf0 * (((1 + n + ((5 / 4) * (n ^ 2)) + ((5 / 4) * (n ^ 3))) * (PHI - PHI0)) _
- (((3 * n) + (3 * (n ^ 2)) + ((21 / 8) * (n ^ 3))) * (Sin(PHI - PHI0)) * (Cos(PHI + PHI0))) _
+ ((((15 / 8) * (n ^ 2)) + ((15 / 8) * (n ^ 3))) * (Sin(2 * (PHI - PHI0))) * (Cos(2 * (PHI + PHI0)))) _
- (((35 / 24) * (n ^ 3)) * (Sin(3 * (PHI - PHI0))) * (Cos(3 * (PHI + PHI0)))))

End Function

mhieuit · 15/2/15

Dear GPE,
em có đoạn code như bên dưói nhưng run không được, anh chị help check code sai chổ nào. thanks all.

Mã:

Option Explicit
Private Sub test()
Dim i As Integer
        For i = 1 To Sheets.Count
            Sheets(i).Range([A16], [A65536].End(xlUp)).Resize(, 24).RowHeight = 25
        Next i
End Sub

comet_1701 · 15/2/15

mhieuit đã viết:
Dear GPE,
em có đoạn code như bên dưói nhưng run không được, anh chị help check code sai chổ nào. thanks all.

Mã:

Option Explicit Private Sub test() Dim i As Integer For i = 1 To Sheets.Count Sheets(i).Range([A16], [A65536].End(xlUp)).Resize(, 24).RowHeight = 25 Next i End Sub

PHP:

Option Explicit
Private Sub test()
Dim i As Integer
        For i = 1 To Sheets.Count
            Sheets(i).Range("A16", Sheets(i).[A65536].End(xlUp)).Resize(, 24).RowHeight = 25
        Next i
End Sub

bạn sửa thế này

Ba Tê · 15/2/15

comet_1701 đã viết:
PHP:

Option Explicit Private Sub test() Dim i As Integer For i = 1 To Sheets.Count Sheets(i).Range("A16", Sheets(i).[A65536].End(xlUp)).Resize(, 24).RowHeight = 25 Next i End Sub

bạn sửa thế này

Đặt chiều cao dòng thì đâu cần Resize() làm gì?
Chỉ cần thế này:

PHP:

Sheets(i).Range("A16", Sheets(i).[A65536].End(xlUp)).RowHeight = 25

Hoặc:

PHP:

Sheets(i).Rows("16:" & Sheets(i).[A65536].End(xlUp).Row).RowHeight = 25

mhieuit · 15/2/15

Dear GPE,
code bên dưới có thể dùng For Each được không ạ?

PHP:

Dim i As Integer
For i = 1 To Sheets.Count
      Sheets(i).Columns("C:D").EntireColumn.Hidden = True   
      Sheets(i).Columns("Q:R").EntireColumn.Hidden = True   
      Sheets(i).Columns("T").ColumnWidth = 10
      Sheets(i).Columns("W").ColumnWidth = 10
Next i

Và code dưới đây có cách nào viết gọn không ạ?

PHP:

With Sheets(i).PageSetup            
   .Zoom = 95            
   .RightHeader = "Page &P of &N"           
   .PrintTitleRows = "$1:$15"            
   .LeftMargin = Application.InchesToPoints(0.5)            
   .RightMargin = Application.InchesToPoints(0.1)           
   .TopMargin = Application.InchesToPoints(0.1)            
   .BottomMargin = Application.InchesToPoints(0.1)        
End With

Thank all.

comet_1701 · 15/2/15

mhieuit đã viết:

Dear GPE,
code bên dưới có thể dùng For Each được không ạ?

PHP:

Dim i As Integer
For i = 1 To Sheets.Count
      Sheets(i).Columns("C:D").EntireColumn.Hidden = True   
      Sheets(i).Columns("Q:R").EntireColumn.Hidden = True   
      Sheets(i).Columns("T").ColumnWidth = 10
      Sheets(i).Columns("W").ColumnWidth = 10
Next i

Và code dưới đây có cách nào viết gọn không ạ?

PHP:

With Sheets(i).PageSetup            
   .Zoom = 95            
   .RightHeader = "Page &P of &N"           
   .PrintTitleRows = "$1:$15"            
   .LeftMargin = Application.InchesToPoints(0.5)            
   .RightMargin = Application.InchesToPoints(0.1)           
   .TopMargin = Application.InchesToPoints(0.1)            
   .BottomMargin = Application.InchesToPoints(0.1)        
End With

Thank all.

PHP:

Sub test()
Dim Ws As Worksheet, i As Long
For Each Ws In Worksheets
      Ws.Columns("C:D").EntireColumn.Hidden = True
      Ws.Columns("Q:R").EntireColumn.Hidden = True
      Ws.Columns("T").ColumnWidth = 10
      Ws.Columns("W").ColumnWidth = 10
Next
End Sub

For each thì thế này

mhieuit · 15/2/15

comet_1701 đã viết:

PHP:

Sub test()
Dim Ws As Worksheet, i As Long
For Each Ws In Worksheets
      Ws.Columns("C:D").EntireColumn.Hidden = True
      Ws.Columns("Q:R").EntireColumn.Hidden = True
      Ws.Columns("T").ColumnWidth = 10
      Ws.Columns("W").ColumnWidth = 10
Next
End Sub

For each thì thế này

dear anh,
còn biến i em không thấy có trong đoạn code. check lại giúp em nhé

Ba Tê · 15/2/15

mhieuit đã viết:
dear anh,
còn biến i em không thấy có trong đoạn code. check lại giúp em nhé

Ngộ quá! Biến khai báo mà không xài thì bỏ, đưa vào chỗ nào được mà check?
Hay là bắt buộc phải đưa vào như vầy:

PHP:

Sub test()
Dim Ws As Worksheet, i As Long
For Each Ws In Worksheets
      i= i + 10     'Híc !'
      Ws.Columns("C:D").EntireColumn.Hidden = True
      Ws.Columns("Q:R").EntireColumn.Hidden = True
      Ws.Columns("T").ColumnWidth = 10
      Ws.Columns("W").ColumnWidth = 10
Next
i=0     'Hu hu'
End Sub

Muốn kiểu khác thì thử như vầy:

PHP:

Sub test()
Dim Ws As Worksheet
For Each Ws In Worksheets
      Ws.Range("C:D, Q:R").EntireColumn.Hidden = True
      Ws.Range("T:T,W:W ").ColumnWidth = 10
Next
End Sub

mhieuit · 16/2/15

Ba Tê đã viết:
Ngộ quá! Biến khai báo mà không xài thì bỏ, đưa vào chỗ nào được mà check?
Hay là bắt buộc phải đưa vào như vầy:

PHP:

Sub test() Dim Ws As Worksheet, i As Long For Each Ws In Worksheets i= i + 10 'Híc !' Ws.Columns("C:D").EntireColumn.Hidden = True Ws.Columns("Q:R").EntireColumn.Hidden = True Ws.Columns("T").ColumnWidth = 10 Ws.Columns("W").ColumnWidth = 10 Next i=0 'Hu hu' End Sub

Muốn kiểu khác thì thử như vầy:

PHP:

Sub test() Dim Ws As Worksheet For Each Ws In Worksheets Ws.Range("C:D, Q:R").EntireColumn.Hidden = True Ws.Range("T:T,W:W ").ColumnWidth = 10 Next End Sub

Dear anh,
em xin lỗi vi em nói không rõ ý ạ,
ý em thế này, vì code của em duyệt qua từng sheet nên em khai báo biến i (sheets(i)), các sheets của em có hình thức giống nhau ạ. anh xem lại giúp em nếu bỏ biến i vậy code có duyệt qua các sheets không anh.

Ba Tê · 16/2/15

mhieuit đã viết:
Dear anh,
em xin lỗi vi em nói không rõ ý ạ,
ý em thế này, vì code của em duyệt qua từng sheet nên em khai báo biến i (sheets(i)), các sheets của em có hình thức giống nhau ạ. anh xem lại giúp em nếu bỏ biến i vậy code có duyệt qua các sheets không anh.

Cứ cho code chạy thử, kết quả như thế nào, có đúng ý không, có chỗ nào chưa đúng... rồi tự nhận xét thôi.
Không cần biến i, 100 sheet nó cũng "quất" tuốt.

loinguyen212 · 24/3/15

Sử dụng with...end with.
Chào mọi người, em muốn hỏi: Có cách nào thực hiện được việc khi đang ở sheet2 mà sử dụng With ... End with để chọn toàn bộ cells của sheet1 không? Em cảm ơn.

hikaru0110 · 25/3/15

Xin mọi người giải thích cho mình về 2 dòng code sau với:

PHP:

Range("SPValues").Columns.Hidden = False       
 Range(Range("SFStart").Offset(1, 0), Range("SFStart").Offset(1, 6).End(xlDown)).ClearContents

phihndhsp · 25/3/15

hikaru0110 đã viết:
PHP:

Range("SPValues").Columns.Hidden = False Range(Range("SFStart").Offset(1, 0), Range("SFStart").Offset(1, 6).End(xlDown)).ClearContents

xóa dữ liệu
lấy vùng có tên SFStart
di chuyển xuống 1 dòng qua 6 cột vùng SFStart làm mốc
sau đó chọn từ dòng hiện tại đến dòng cuối cùng có dữ liệu, sau đó xóa dữ liều

hoangtamit2011 · 11/4/15

Nhờ các bác giúp dùm em đoạn code này , do code viết từ tiếng trung nên khi qua gởi qua việt nam , nó lỗi code tùm lum hết. Các bác có thể giải thích code này dùm em vì em không rành lắm.

Option Explicit
Private Sub CommandButton1_Click()
Dim ans As Variant
Dim Sh As Variant

ans = MsgBox("?涓单编号?？", vbYesNo, "")
If ans = vbNo Then Exit Sub
For Each Sh In Worksheets
Sh.Cells(3, 8) = Cells(2, 8) & Mid(Year(Date), 3, 2) & Application.Text(Month(Date), "00") & Application.Text(Day(Date), "00") & Application.Text(Hour(Time), "00") & Application.Text(Minute(Time), "00") & Application.Text(Second(Time), "00")
Next Sh
End Sub

Private Sub CommandButton2_Click()
Dim ans As Variant
Dim ┑LS As Variant
ans = MsgBox("保存当前生产┑ヂ?？", vbYesNo, "NKV CO.LTD")
If ans = vbNo Then Exit Sub
Application.ScreenUpdating = False
Application.DisplayAlerts = False
┑LS = ActiveWorkbook.Path & "\" & Cells(7, 8) & Cells(5, 2) & Cells(9, 2) & "_" & Cells(3, 8) & "_最?生产┑?xls"
Sheets("最?生产┑?).Copy
ActiveWorkbook.SaveAs Filename:=┑LS, FileFormat:=xlNormal, CreateBackup:=False
ActiveWorkbook.Close
MsgBox Cells(7, 8) & Cells(5, 2) & "_" & Cells(3, 8) & Cells(9, 2) & "_最?生产┑?xls?丫"保存", , "NKV CO.LTD"
End Sub

hue.ngoc · 31/8/15

frantliem · 20/11/15

Các anh chị giúp em đoạn mã sau:
ActiveCell.FormulaR1C1 = _
"=""Tên khách hàng: ""&dulieu!R[-5]C[41]&""& M&""&ChrW(227)&"" khách hàng: ""&dulieu!R[-5]C[42]"
Do trong VBA không thể hiện tiếng việt nên em viết "Mã khách hàng" chèn vào đoạn mã trên.
Tuy nhiên, máy báo lỗi không chạy được.

doveandrose · 20/11/15

frantliem đã viết:
Các anh chị giúp em đoạn mã sau:
ActiveCell.FormulaR1C1 = _
"=""Tên khách hàng: ""&dulieu!R[-5]C[41]&""& M&""&ChrW(227)&"" khách hàng: ""&dulieu!R[-5]C[42]"
Do trong VBA không thể hiện tiếng việt nên em viết "Mã khách hàng" chèn vào đoạn mã trên.
Tuy nhiên, máy báo lỗi không chạy được.

http://www.giaiphapexcel.com/forum/...hững-thắc-mắc-về-code-VBA&p=689860#post689860

frantliem · 20/11/15

Xin lỗi, em up cả hai luồng
Có anh chị nào giúp với

Lequocvan · 20/11/15

Em có sử dụng code như sau:
Public Function CotName(i)
Alphabet = "ABCDEFGHIJKLMNOPQRSTUVWXYZ"
If Int((i - 1) / 26) = 0 Then
Chu1 = ""
Else
Chu1 = Mid(Alphabet, Int((i - 1) / 26), 1)
End If
If i Mod 26 = 0 Then
Chu2 = "Z"
Else
Chu2 = Mid(Alphabet, i Mod 26, 1)
End If
CotName = Chu1 & Chu2
End Function

Function msit80_kiemtra()
Range("A1").Select
socot = Range("A1").End(xlToRight).Column
For BienA = 1 To socot
Tencot = CotName(BienA)
Select Case Range(Tencot & "1").value
Case "brcd", "custseq", "custnm", "apprseq", "apprdt", "apprmatdt", "ccy", "appramt", "dsbsseq", "dsbsdt", "dsbsmatdt", "sprd", "sprdpst", "dsbsamt", "dsbsccy", "rpmtamt", "intamt", "dsbsbal", "dsbsamt2", "rpmtamt2", "intamt2", "subunit", "custstscd", "custtpcd", "custtpnm", "custdtltpcd", "custdtltpnm", "ecomist", "ecomistnm", "taxtpcdloc", "taxtpcdlocnm", "ofcno", "ofcnm", "pstintamt", "pstintamt2", "buscd", "lntpcd", "lnsbtpcd", "lstrpmtdt", "lstintchrgprd", "nxtrpmtschddt", "nxtintschddt", "exmtintamt", "exmtintamt2", "finainsttpcd", "finainsttpcdnm", "sicdloc", "province", "provincenm", "district", "districtnm", "zipcd", "addr1", "secured", "fndrstpcd", "fndrsnm", "exemptint", "exemptinttype", "fndprpstpcd", "fndprpstpcd_code", "intrpmtamt", "AQCCDFIN", "intrpmtamt2", "commcd", "commmn", "grpno", "trctcd", "trctnm", "BSNSSCLTPCD", "usrid", "usrnm", "acramt", "lceqa", "yrdays", "intcmth", "intrpymth", "inttrmmth", "remark"
Case Else
Msg ("Zero MSIT80 !!!!!")
Exit Function
End Select
Next
Msg ("Good" & vbCrLf & "Good" & vbCrLf & "Good")
End Function

Em muốn biết có cách nào phải so sánh từ A1, B1, C1, ... với tuần tự dãy màu xanh nếu đúng toàn bộ (từng giá trị ô một), đúng hết thì ra 1 thông báo Good. còn nếu chỉ cần 1 giá trị sai là exit thì làm như thế nào ah?

ndu96081631 · 20/11/15

Lequocvan đã viết:
Em muốn biết có cách nào phải so sánh từ A1, B1, C1, ... với tuần tự dãy màu xanh nếu đúng toàn bộ (từng giá trị ô một), đúng hết thì ra 1 thông báo Good. còn nếu chỉ cần 1 giá trị sai là exit thì làm như thế nào ah?

Như vầy được không:

Mã:

Public dic As Object
Private Sub Auto_Open()
  Dim arr, item
  arr = Array("brcd", "custseq", "custnm", "apprseq", "apprdt", "apprmatdt", _
              "ccy", "appramt", "dsbsseq", "dsbsdt", "dsbsmatdt", "sprd", _
              "sprdpst", "dsbsamt", "dsbsccy", "rpmtamt", "intamt", "dsbsbal", _
              "dsbsamt2", "rpmtamt2", "intamt2", "subunit", "custstscd", "custtpcd", _
              "custtpnm", "custdtltpcd", "custdtltpnm", "ecomist", "ecomistnm", "taxtpcdloc", _
              "taxtpcdlocnm", "ofcno", "ofcnm", "pstintamt", "pstintamt2", "buscd", _
              "lntpcd", "lnsbtpcd", "lstrpmtdt", "lstintchrgprd", "nxtrpmtschddt", "nxtintschddt", _
              "exmtintamt", "exmtintamt2", "finainsttpcd", "finainsttpcdnm", "sicdloc", "province", _
              "provincenm", "district", "districtnm", "zipcd", "addr1", "secured", _
              "fndrstpcd", "fndrsnm", "exemptint", "exemptinttype", "fndprpstpcd", "fndprpstpcd_code", _
              "intrpmtamt", "AQCCDFIN", "intrpmtamt2", "commcd", "commmn", "grpno", _
              "trctcd", "trctnm", "BSNSSCLTPCD", "usrid", "usrnm", "acramt", _
              "lceqa", "yrdays", "intcmth", "intrpymth", "inttrmmth", "remark")
  If dic Is Nothing Then
    Set dic = CreateObject("Scripting.Dictionary")
    dic.CompareMode = vbTextCompare
    For Each item In arr
      dic.Add item, Nothing
    Next
  End If
End Sub
Sub msit80_kiemtra()
  Dim rng As Range, cel As Range, bChk As Boolean
  If dic Is Nothing Then Auto_Open
  Set rng = Range("A1", Range("A1").End(xlToRight))
  For Each cel In rng
    If Not dic.Exists(cel.Value) Then
      bChk = True
      Exit For
    End If
  Next
  If bChk Then
    MsgBox "Zero MSIT80 !!!!!"
  Else
    MsgBox "Good" & vbLf & "Good" & vbLf & "Good"
  End If
End Sub

Lequocvan · 23/11/15

Dạ cám ơn Thầy nhưng ý của em là ktra lần lượt a1=brcd, b1=custseq, c1=custnm, ... bz1=remark. Nếu như đúng toàn bộ thì ra thông báo good; còn nếu chỉ cần ít nhất một trong những (78) phép so sánh trên có kết quả sai thì báo zero và thoát.

doveandrose · 23/11/15

Lequocvan đã viết:
Dạ cám ơn Thầy nhưng ý của em là ktra lần lượt a1=brcd, b1=custseq, c1=custnm, ... bz1=remark. Nếu như đúng toàn bộ thì ra thông báo good; còn nếu chỉ cần ít nhất một trong những (78) phép so sánh trên có kết quả sai thì báo zero và thoát.

Mã:

Public Sub hello()
Dim arr, r As Long, dArr
arr = Array("brcd", "custseq", "custnm", "apprseq", "apprdt", "apprmatdt", _
              "ccy", "appramt", "dsbsseq", "dsbsdt", "dsbsmatdt", "sprd", _
              "sprdpst", "dsbsamt", "dsbsccy", "rpmtamt", "intamt", "dsbsbal", _
              "dsbsamt2", "rpmtamt2", "intamt2", "subunit", "custstscd", "custtpcd", _
              "custtpnm", "custdtltpcd", "custdtltpnm", "ecomist", "ecomistnm", "taxtpcdloc", _
              "taxtpcdlocnm", "ofcno", "ofcnm", "pstintamt", "pstintamt2", "buscd", _
              "lntpcd", "lnsbtpcd", "lstrpmtdt", "lstintchrgprd", "nxtrpmtschddt", "nxtintschddt", _
              "exmtintamt", "exmtintamt2", "finainsttpcd", "finainsttpcdnm", "sicdloc", "province", _
              "provincenm", "district", "districtnm", "zipcd", "addr1", "secured", _
              "fndrstpcd", "fndrsnm", "exemptint", "exemptinttype", "fndprpstpcd", "fndprpstpcd_code", _
              "intrpmtamt", "AQCCDFIN", "intrpmtamt2", "commcd", "commmn", "grpno", _
              "trctcd", "trctnm", "BSNSSCLTPCD", "usrid", "usrnm", "acramt", _
              "lceqa", "yrdays", "intcmth", "intrpymth", "inttrmmth", "remark")
dArr = [COLOR=#ff0000][SIZE=3][B]Sheet3[/B][/SIZE][/COLOR].Range("A1:BZ1").Value
For r = 1 To UBound(dArr, 2) Step 1
    If dArr(1, r) <> arr(r - 1) Then Exit For
Next
If r <= UBound(dArr, 2) Then MsgBox "error at cell " & Cells(1, r).Address Else MsgBox "Good"
End Sub

VetMini · 23/11/15

If join(application.transpose(application.transpose("a1:bz1")),",") <> "brcd,custseq,custnm,apprseq,apprdt,apprmatdt,ccy,appramt,dsbsseq,dsbsdt,dsbsmatdt,sprd,sprdpst,dsbsamt,dsbsccy,rpmtamt,intamt,dsbsbal,dsbsamt2,rpmtamt2,intamt2,subunit,custstscd,custtpcd,custtpnm,custdtltpcd,custdtltpnm,ecomist,ecomistnm,taxtpcdloc,taxtpcdlocnm,ofcno,ofcnm,pstintamt,pstintamt2,buscd,lntpcd,lnsbtpcd,lstrpmtdt,lstintchrgprd,nxtrpmtschddt,nxtintschddt,exmtintamt,exmtintamt2,finainsttpcd,finainsttpcdnm,sicdloc,province,provincenm,district,districtnm,zipcd,addr1,secured,fndrstpcd,fndrsnm,exemptint,exemptinttype,fndprpstpcd,fndprpstpcd_code,intrpmtamt,AQCCDFIN,intrpmtamt2,commcd,commmn,grpno,trctcd,trctnm,BSNSSCLTPCD,usrid,usrnm,acramt,lceqa,yrdays,intcmth,intrpymth,inttrmmth,remark" Then
...

vippmuhm · 1/12/15

Các cao thủ gỡ giúp em vụ này với:
Chả là em muốn làm cái module tổng hợp máy thi công từ nhiều hạng mục công trình với yêu cầu:
- Tổng hợp máy theo mã hiệu máy
- Khối lượng và Giá tiền tính theo pp cộng dồn
- Đơn giá tính theo pp bình quân gia quyền (Tổng giá trị/Tổng khối lượng)

Em code thế này mà nó không cho kq đúng:

Public Sub TongHopMayTC()
Dim Ws As Worksheet, srcDAT, dstDAT(1 To 65000, 1 To 8), r, i As Long

With CreateObject("scripting.dictionary")
For Each Ws In Worksheets
If Ws.Name <> "tonghop.M" Then
srcDAT = Ws.Range("A5", Ws.Range("J65000").End(xlUp))

For r = 1 To UBound(srcDAT)
If Not IsEmpty(srcDAT(r, 2)) Then
If Not .exists(srcDAT(r, 2)) Then
i = i + 1
.Add srcDAT(r, 2), i
dstDAT(i, 1) = i
dstDAT(i, 2) = srcDAT(r, 2)
dstDAT(i, 3) = srcDAT(r, 3)
dstDAT(i, 4) = srcDAT(r, 4)
dstDAT(i, 5) = srcDAT(r, 5)
dstDAT(i, 6) = ":v"
dstDAT(i, 7) = srcDAT(r, 7)
dstDAT(i, 8) = srcDAT(r, 8)
Else
dstDAT(.Item(srcDAT(r, 2)), 5) = dstDAT(.Item(srcDAT(r, 2)), 5) + srcDAT(r, 5) ' Cong don khoi luong
dstDAT(.Item(srcDAT(r, 2)), 8) = dstDAT(.Item(srcDAT(r, 2)), 8) + srcDAT(r, 8) ' Cong don thanh tien
If dstDAT(.Item(srcDAT(r, 2)), 5) <> 0 Then dstDAT(.Item(srcDAT(r, 2)), 7) = dstDAT(.Item(srcDAT(r, 2)), 8) / dstDAT(.Item(srcDAT(r, 2)), 5) 'Tinh don gia theo PP binh quan
End If
End If
Next r

End If
Next Ws
End With

With Sheets("tonghop.M")
.UsedRange.Clear
.Range("A1").Resize(i, 8) = dstDAT
.UsedRange.Font.Name = ".vntime"
.UsedRange.Borders.LineStyle = 1
.UsedRange.Columns.AutoFit
End With

End Sub

Cảm ơn các bác,

giangleloi · 1/12/15

vippmuhm đã viết:
Các cao thủ gỡ giúp em vụ này với:
Chả là em muốn làm cái module tổng hợp máy thi công từ nhiều hạng mục công trình với yêu cầu:
- Tổng hợp máy theo mã hiệu máy
- Khối lượng và Giá tiền tính theo pp cộng dồn
- Đơn giá tính theo pp bình quân gia quyền (Tổng giá trị/Tổng khối lượng)

Em code thế này mà nó không cho kq đúng:

Public Sub TongHopMayTC()
Dim Ws As Worksheet, srcDAT, dstDAT(1 To 65000, 1 To 8), r, i As Long

With CreateObject("scripting.dictionary")
For Each Ws In Worksheets
If Ws.Name <> "tonghop.M" Then
srcDAT = Ws.Range("A5", Ws.Range("J65000").End(xlUp))

For r = 1 To UBound(srcDAT)
If Not IsEmpty(srcDAT(r, 2)) Then
If Not .exists(srcDAT(r, 2)) Then
i = i + 1
.Add srcDAT(r, 2), i
dstDAT(i, 1) = i
dstDAT(i, 2) = srcDAT(r, 2)
dstDAT(i, 3) = srcDAT(r, 3)
dstDAT(i, 4) = srcDAT(r, 4)
dstDAT(i, 5) = srcDAT(r, 5)
dstDAT(i, 6) = ":v"
dstDAT(i, 7) = srcDAT(r, 7)
dstDAT(i, 8) = srcDAT(r, 8)
Else
dstDAT(.Item(srcDAT(r, 2)), 5) = dstDAT(.Item(srcDAT(r, 2)), 5) + srcDAT(r, 5) ' Cong don khoi luong
dstDAT(.Item(srcDAT(r, 2)), 8) = dstDAT(.Item(srcDAT(r, 2)), 8) + srcDAT(r, 8) ' Cong don thanh tien
If dstDAT(.Item(srcDAT(r, 2)), 5) <> 0 Then dstDAT(.Item(srcDAT(r, 2)), 7) = dstDAT(.Item(srcDAT(r, 2)), 8) / dstDAT(.Item(srcDAT(r, 2)), 5) 'Tinh don gia theo PP binh quan
End If
End If
Next r

End If
Next Ws
End With

With Sheets("tonghop.M")
.UsedRange.Clear
.Range("A1").Resize(i, 8) = dstDAT
.UsedRange.Font.Name = ".vntime"
.UsedRange.Borders.LineStyle = 1
.UsedRange.Columns.AutoFit
End With

End Sub

Cảm ơn các bác,

Sửa lại theo code của bạn nhé: (Kiểm tra coi có sai chỗ nào không)

Mã:

Public Sub TongHopMayTC()
Dim Ws As Worksheet, DL, kq(1 To 65000, 1 To 8), r, i As Long
   With CreateObject("scripting.dictionary")
     For Each Ws In Worksheets
       If Ws.Name <> "tonghop.M" Then
          DL = Ws.Range(Ws.[A5], Ws.[H65000].End(xlUp)).Value
            For r = 1 To UBound(DL)
              If DL(r, 2) <> Empty Then
                If Not .exists(DL(r, 2)) Then
                 i = i + 1
                .Add DL(r, 2), i
                kq(i, 1) = i
                kq(i, 2) = DL(r, 2)
                kq(i, 3) = DL(r, 3)
                kq(i, 4) = DL(r, 4)
                kq(i, 5) = DL(r, 5)
                kq(i, 6) = ":v"
                kq(i, 7) = DL(r, 7)
                kq(i, 8) = DL(r, 8)
               Else
                kq(.Item(DL(r, 2)), 5) = kq(.Item(DL(r, 2)), 5) + DL(r, 5)
                kq(.Item(DL(r, 2)), 8) = kq(.Item(DL(r, 2)), 8) + DL(r, 8)
                If kq(.Item(DL(r, 2)), 5) <> 0 Then kq(.Item(DL(r, 2)), 7) _
                  = kq(.Item(DL(r, 2)), 8) / kq(.Item(DL(r, 2)), 5)
               End If
             End If
          Next r
      End If
    Next Ws
  End With
With Sheets("tonghop.M")
    .UsedRange.Clear
    .[A2].Resize(i, 8) = kq
    .UsedRange.Font.Name = ".vntime"
    .UsedRange.Borders.LineStyle = 1
    .UsedRange.Columns.AutoFit
End With
End Sub

vippmuhm · 1/12/15

giangleloi đã viết:

Sửa lại theo code của bạn nhé: (Kiểm tra coi có sai chỗ nào không)

Mã:

Public Sub TongHopMayTC()
Dim Ws As Worksheet, DL, kq(1 To 65000, 1 To 8), r, i As Long
   With CreateObject("scripting.dictionary")
     For Each Ws In Worksheets
       If Ws.Name <> "tonghop.M" Then
          DL = Ws.Range(Ws.[A5], Ws.[H65000].End(xlUp)).Value
            For r = 1 To UBound(DL)
              If DL(r, 2) <> Empty Then
                If Not .exists(DL(r, 2)) Then
                 i = i + 1
                .Add DL(r, 2), i
                kq(i, 1) = i
                kq(i, 2) = DL(r, 2)
                kq(i, 3) = DL(r, 3)
                kq(i, 4) = DL(r, 4)
                kq(i, 5) = DL(r, 5)
                kq(i, 6) = ":v"
                kq(i, 7) = DL(r, 7)
                kq(i, 8) = DL(r, 8)
               Else
                kq(.Item(DL(r, 2)), 5) = kq(.Item(DL(r, 2)), 5) + DL(r, 5)
                kq(.Item(DL(r, 2)), 8) = kq(.Item(DL(r, 2)), 8) + DL(r, 8)
                If kq(.Item(DL(r, 2)), 5) <> 0 Then kq(.Item(DL(r, 2)), 7) _
                  = kq(.Item(DL(r, 2)), 8) / kq(.Item(DL(r, 2)), 5)
               End If
             End If
          Next r
      End If
    Next Ws
  End With
With Sheets("tonghop.M")
    .UsedRange.Clear
    .[A2].Resize(i, 8) = kq
    .UsedRange.Font.Name = ".vntime"
    .UsedRange.Borders.LineStyle = 1
    .UsedRange.Columns.AutoFit
End With
End Sub

Nét rồi bác, số liệu đẹp mỹ mãn luôn!
Cảm ơn bác nhé!

babe_nice · 1/12/15

giangleloi đã viết:

Sửa lại theo code của bạn nhé: (Kiểm tra coi có sai chỗ nào không)

Mã:

Public Sub TongHopMayTC()
Dim Ws As Worksheet, DL, kq(1 To 65000, 1 To 8), r, i As Long
   With CreateObject("scripting.dictionary")
     For Each Ws In Worksheets
       If Ws.Name <> "tonghop.M" Then
          DL = Ws.Range(Ws.[A5], Ws.[H65000].End(xlUp)).Value
            For r = 1 To UBound(DL)
              If DL(r, 2) <> Empty Then
                If Not .exists(DL(r, 2)) Then
                 i = i + 1
                .Add DL(r, 2), i
                kq(i, 1) = i
                kq(i, 2) = DL(r, 2)
                kq(i, 3) = DL(r, 3)
                kq(i, 4) = DL(r, 4)
                kq(i, 5) = DL(r, 5)
                kq(i, 6) = ":v"
                kq(i, 7) = DL(r, 7)
                kq(i, 8) = DL(r, 8)
               Else
                kq(.Item(DL(r, 2)), 5) = kq(.Item(DL(r, 2)), 5) + DL(r, 5)
                kq(.Item(DL(r, 2)), 8) = kq(.Item(DL(r, 2)), 8) + DL(r, 8)
                If kq(.Item(DL(r, 2)), 5) <> 0 Then kq(.Item(DL(r, 2)), 7) _
                  = kq(.Item(DL(r, 2)), 8) / kq(.Item(DL(r, 2)), 5)
               End If
             End If
          Next r
      End If
    Next Ws
  End With
With Sheets("tonghop.M")
    .UsedRange.Clear
    .[A2].Resize(i, 8) = kq
    .UsedRange.Font.Name = ".vntime"
    .UsedRange.Borders.LineStyle = 1
    .UsedRange.Columns.AutoFit
End With
End Sub

em thấy khác ở 2 chỗ:

Mã:

[COLOR=#000000] DL = Ws.Range(Ws.[A5], Ws.[H65000].End(xlUp)).[/COLOR][B][COLOR=#ff0000]Value[/COLOR]' -- [/B]

Và chỗ này, kiểm tra key trống, tồn tại:

Mã:

 If DL(r, 2) <> Empty Then                If Not .exists(DL(r, 2)) Then

Nói chung, là em chưa bằng chủ thớt, em nhìn thấy cũng là tiếp xúc nhiều mà thôi.
Em test rồi, mởi chủ thớt test

giangleloi · 1/12/15

babe_nice đã viết:
em thấy khác ở 2 chỗ:

Mã:

[COLOR=#000000] DL = Ws.Range(Ws.[A5], Ws.[H65000].End(xlUp)).[/COLOR][B][COLOR=#ff0000]Value[/COLOR]' -- [/B]

Và chỗ này, kiểm tra key trống, tồn tại:

Mã:

If DL(r, 2) <> Empty Then If Not .exists(DL(r, 2)) Then

Nói chung, là em chưa bằng chủ thớt, em nhìn thấy cũng là tiếp xúc nhiều mà thôi.
Em test rồi, mởi chủ thớt test

Cái đó tôi chỉ viết lại theo cách của tôi thôi, vấn đề là nằm ở chỗ này:

Mã:

[COLOR=#000000] DL = Ws.Range([/COLOR][COLOR=#ff0000]Ws.[A5], Ws.[H65000][/COLOR][COLOR=#000000].End(xlUp)).[/COLOR]Value

Kiều Mạnh · 1/12/15

hpkhuong đã viết:
Các bạn đang giao lưu vấn đề chi đây.??? Bạn có chắc cái bạn phát hiện là điều làm code chạy đúng...???

chắc người ta đang hỏi (r,2) nếu có dữ liệu thì chạy ...nếu không thì khỏi key mằm chi cho mất công đó mà... --=0

babe_nice · 1/12/15

hpkhuong đã viết:
Các bạn đang giao lưu vấn đề chi đây.??? Bạn có chắc cái bạn phát hiện là điều làm code chạy đúng...???

Không, không,....anh hpkhuong có hiểu nhầm ý em không ạ?
Em chỉ nói kiến thức em chỉ nhận thấy như thế, còn như anh giangleloi đã bổ sung mấu chốt rồi ạ.
Em cũng nói ngay là em không bằng chủ thớt, tức là không viết được như thế. Nếu viết được như thế thì em sẽ chú ý mấy điểm em nói...và đương nhiên code chạy vẫn sai.
Ý em không phải để nói đúng sai hay chạy hay không ạ? em xin hết, không tham gia ý gì nữa....

Lequocvan · 3/12/15

Em đã chỉnh sửa theo code mà các ACE cho nhưng giờ nó báo lỗi out

Sub msit80_kiemtra()
Dim r As Long, arr, dArr
arr = Array("brcd", "custseq", "custnm", "apprseq", "apprdt", "apprmatdt", _
"ccy", "appramt", "dsbsseq", "dsbsdt", "dsbsmatdt", "sprd", "sprdpst", "dsbsamt", _
"dsbsccy", "rpmtamt", "intamt", "dsbsbal", "dsbsamt2", "rpmtamt2", "intamt2", "subunit", _
"custstscd", "custtpcd", "custtpnm", "custdtltpcd", "custdtltpnm", "ecomist", "ecomistnm", _
"taxtpcdloc", "taxtpcdlocnm", "ofcno", "ofcnm", "pstintamt", "pstintamt2", "buscd", "lntpcd", _
"lnsbtpcd", "lstrpmtdt", "lstintchrgprd", "nxtrpmtschddt", "nxtintschddt", "exmtintamt", "exmtintamt2", _
"finainsttpcd", "finainsttpcdnm", "sicdloc", "province", "provincenm", "district", "districtnm", "zipcd", _
"addr1", "secured", "fndrstpcd", "fndrsnm", "exemptint", "exemptinttype", "fndprpstpcd", "fndprpstpcd_code", _
"intrpmtamt", "AQCCDFIN", "intrpmtamt2", "commcd", "commmn", "grpno", "trctcd", "trctnm", "BSNSSCLTPCD", "usrid", _
"usrnm", "acramt", "lceqa", "yrdays", "intcmth", "intrpymth", "inttrmmth", "remark", "chitiet_htls")

Dim tenWsVBA, tenWs As String
tenWsVBA = ActiveSheet.CodeName
tenWs = ActiveSheet.Name
dArr = Worksheets(tenWsVBA).Range("A1:CA1").value

For r = 1 To UBound(dArr, 2) Step 1
If dArr(1, r) <> arr(r - 1) Then Exit For
Next
If r <= UBound(dArr, 2) Then MsgBox "error at cell " & Cells(1, r).Address Else MsgBox "Good"
End Sub
Khi chạy đến hôm nay lại bị phát sinh lỗi sau: [TABLE="width: 100%"]
[TR]
[TD="align: left"][/TD]
[/TR]
[TR]
[TD="align: left"]Subscript out of range (Error 9) và em vào debug thì ko biết chỉnh ntn ah? Mong mọi người chỉ giúp?[/TD]
[/TR]
[/TABLE]

Hoàng Trọng Nghĩa · 3/12/15

Lequocvan đã viết:
Sub msit80_kiemtra()
Dim r As Long, arr, dArr
arr = Array("brcd", "custseq", "custnm", "apprseq", "apprdt", "apprmatdt", _
"ccy", "appramt", "dsbsseq", "dsbsdt", "dsbsmatdt", "sprd", "sprdpst", "dsbsamt", _
"dsbsccy", "rpmtamt", "intamt", "dsbsbal", "dsbsamt2", "rpmtamt2", "intamt2", "subunit", _
"custstscd", "custtpcd", "custtpnm", "custdtltpcd", "custdtltpnm", "ecomist", "ecomistnm", _
"taxtpcdloc", "taxtpcdlocnm", "ofcno", "ofcnm", "pstintamt", "pstintamt2", "buscd", "lntpcd", _
"lnsbtpcd", "lstrpmtdt", "lstintchrgprd", "nxtrpmtschddt", "nxtintschddt", "exmtintamt", "exmtintamt2", _
"finainsttpcd", "finainsttpcdnm", "sicdloc", "province", "provincenm", "district", "districtnm", "zipcd", _
"addr1", "secured", "fndrstpcd", "fndrsnm", "exemptint", "exemptinttype", "fndprpstpcd", "fndprpstpcd_code", _
"intrpmtamt", "AQCCDFIN", "intrpmtamt2", "commcd", "commmn", "grpno", "trctcd", "trctnm", "BSNSSCLTPCD", "usrid", _
"usrnm", "acramt", "lceqa", "yrdays", "intcmth", "intrpymth", "inttrmmth", "remark", "chitiet_htls")

Dim tenWsVBA, tenWs As String
tenWsVBA = ActiveSheet.CodeName
tenWs = ActiveSheet.Name
dArr = Worksheets(tenWsVBA).Range("A1:CA1").value

For r = 1 To UBound(dArr, 2) Step 1
If dArr(1, r) <> arr(r - 1) Then Exit For
Next
If r <= UBound(dArr, 2) Then MsgBox "error at cell " & Cells(1, r).Address Else MsgBox "Good"
End Sub
Khi chạy đến hôm nay lại bị phát sinh lỗi sau: [TABLE="width: 100%"]
[TR]
[TD="align: left"][/TD]
[/TR]
[TR]
[TD="align: left"]Subscript out of range (Error 9) và em vào debug thì ko biết chỉnh ntn ah? Mong mọi người chỉ giúp?[/TD]
[/TR]
[/TABLE]

Tôi nghĩ mảng "arr" so với mảng "dArr" thiếu một hoặc vài phần tử tương ứng.

nguyenhuutinh25 · 6/12/15

Mình có file đính kèm tạo lịch calendar khi kích chọn 1 ô trong sheet thì hiện lên lịch để chọn ngày tháng năm, thì được rồi, nhưng mình muốn tạo 2 hoặc ba cột nữa, vi dụ: trong file gửi kèm là cột B4:B30, nhưng mình muốn tạo thêm cột K4:K30, M4:M30 thì chỉnh code lại như thế nào mong các bạn chỉ dùm mình, mình không phải dân VBA nên chi tiết càng tốt các bạn nhé, thank nhiều! -=.,,

Hong.Van · 6/12/15

nguyenhuutinh25 đã viết:
Mình có file đính kèm tạo lịch calendar khi kích chọn 1 ô trong sheet thì hiện lên lịch để chọn ngày tháng năm, thì được rồi, nhưng mình muốn tạo 2 hoặc ba cột nữa, vi dụ: trong file gửi kèm là cột B4:B30, nhưng mình muốn tạo thêm cột K4:K30, M4:M30 thì chỉnh code lại như thế nào mong các bạn chỉ dùm mình, mình không phải dân VBA nên chi tiết càng tốt các bạn nhé, thank nhiều!

Bạn sửa chỗ này (thêm chỗ màu đỏ)

Mã:

If Intersect(Target, [COLOR=#ff0000]Union([/COLOR][B4:B30][COLOR=#ff0000], [k4:k30])[/COLOR]) Is Nothing Or Target.Count > 1 Then

tueyennhi · 10/12/15

Cho em hỏi đoạn code này của thầy ndu

Option Explicit
Function Filter2DArray(ByVal SourceArray, ByVal ColIndex As Long, ByVal SearchText As String, ByVal HasTitle As Boolean)
Dim aTmp, arr, dic, aKey
Dim lR As Long, lC As Long, dTmpVal As Double
Dim bChk As Boolean
On Error Resume Next
Set dic = CreateObject("Scripting.Dictionary")
aTmp = SourceArray
ColIndex = ColIndex + LBound(aTmp, 2) - 1
bChk = (InStr("><=", Left(SearchText, 1)) > 0)
For lR = LBound(aTmp, 1) - HasTitle To UBound(aTmp, 1)
If bChk And SearchText <> "" Then
dTmpVal = CDbl(aTmp(lR, ColIndex))
If Evaluate(dTmpVal & SearchText) Then dic.Add lR, ""
Else
If Left(SearchText, 1) = "!" Then
If Not (UCase(aTmp(lR, ColIndex)) Like UCase(Mid(SearchText, 2, Len(SearchText)))) Then dic.Add lR, ""
Else
If UCase(aTmp(lR, ColIndex)) Like UCase(SearchText) Then dic.Add lR, ""
End If
End If
Next
If dic.Count > 0 Then
aKey = dic.Keys
ReDim arr(LBound(aTmp, 1) To UBound(aKey) + LBound(aTmp, 1) - HasTitle, LBound(aTmp, 2) To UBound(aTmp, 2))
For lR = LBound(aTmp, 1) - HasTitle To UBound(aKey) + LBound(aTmp, 1) - HasTitle
For lC = LBound(aTmp, 2) To UBound(aTmp, 2)
arr(lR, lC) = aTmp(aKey(lR - LBound(aTmp, 1) + HasTitle), lC)
Next
Next
If HasTitle Then
For lC = LBound(aTmp, 2) To UBound(aTmp, 2)
arr(LBound(aTmp, 1), lC) = aTmp(LBound(aTmp, 1), lC)
Next
End If
End If
Filter2DArray = arr
End Function
Function SheetExists(ByVal SheetName As String) As Boolean
On Error Resume Next
SheetExists = Not Worksheets(SheetName) Is Nothing
End Function
Sub Main()
Dim aSrc, aRes
Dim wks As Worksheet, wksSrc As Worksheet, dic As Object
Dim SheetName As String
Dim lR As Long, lCount As Long
Set wksSrc = Worksheets("Sheet1")
aSrc = wksSrc.Range("A1:d10000")
Set dic = CreateObject("Scripting.Dictionary")
On Error Resume Next
Application.ScreenUpdating = False
For lR = 2 To UBound(aSrc, 1)
SheetName = CStr(aSrc(lR, 3))
If Len(SheetName) Then
If Not dic.Exists(SheetName) Then
dic.Add SheetName, lR
If Not SheetExists(SheetName) Then
lCount = lCount + 1
With Worksheets.Add(After:=Worksheets(lCount))
.Name = SheetName
.Tab.Color = vbRed
End With
Else
Worksheets(SheetName).Tab.Color = False
End If
Set wks = Worksheets(SheetName)
aRes = Filter2DArray(aSrc, 3, SheetName, True)
wks.UsedRange.ClearContents
wks.Range("A1").Resize(UBound(aRes, 1), 3).Value = aRes
End If
End If
Next
wksSrc.Select
Application.ScreenUpdating = True
MsgBox "Done!"
End Sub

Code dùng để tách sheet theo dữ liệu ở cột C. File của thầy có 3 cột. Vậy cho em hỏi áp dụng cho file có nhiều hơn 3 cột thì em cần thay đổi mã lệnh nào ạ? Và nếu dữ liệu tách của em không nằm ở cột C mà ở cột bất kỳ thì em thay đổi chỗ nào?? Mong mọi người giải đáp giúp em!

tueyennhi · 10/12/15

À em hiểu rồi mấu chốt là ở đoạn aSrc = wksSrc.Range("A1:C10000")

Cho em hỏi nếu như ở sheet dữ liệu em có tiêu để ví dụ như
Danh sách lớp…
Niên khóa
Thì làm thế nào để lặp lại tiêu để đó ở các sheet được tách ra?
Nói cách khác định dạng sẽ được giữ nguyên như file mẹ.

muwa04 · 24/12/15

Gửi các anh em trong diễn đàn!
Do ở topic, bác Trung Chinh đã lâu không onl nên xin mạn phép nhờ các cao nhân giúp đỡ sửa lệnh của file mẫu (đính kèm)
Link topic: http://www.giaiphapexcel.com/forum/showthread.php?81851-Soạn-thảo-văn-bản-Word-từ-Excel

Mình có chút ý kiến về File Excel_19-6-2015.xls
1. Khi gõ 1 số ở sheet Data (C5: 80000) Nếu kích đúp chuột thì sẽ bị nhảy số 80,000 đồng
Để vậy cũng tiện nhưng nếu lỡ tay kích đúp thì rất khó sửa.
Bỏ giúp mình việc kick đúp chuột khỏi bị đổi giá trị được không?
(Mình mò thì tại ShData (Data) có xóa đoạn:
With Selection(2, 1)
If .Value = 0 Then
.Value = "=docso(" & Selection & ")"
.Value = .Value
End If
End With
Selection = "=fixed(" & Selection & ",0)"
Selection = Selection.Value & " " & ChrW(273) & ChrW(7891) & "ng"
thì thấy nó không nhảy thêm "đồng" nữa - không biết có đúng không? Xóa có bị sang cái khác không?)

2. Khi để số sheet Data (C5: 80000) thì khi chạy file (Ctrl + Shift + W) ra file Ngay 30.12.doc , các số đều không có dấu phân cách các hàng (VD: 80,000)
Mình đang cần khi chạy file thì ra kết quả có dấu phân cách các hàng của số. Giúp mình với.

Cám ơn các anh em rất nhiều!

maint1311 · 1/2/16

Giải thích và chỉnh sửa giúp mình file chứa macro, mình mở file báo lỗi "Missing end Braket". Cám ơn bạn nhiều!

dhn46 · 2/2/16

maint1311 đã viết:
Giải thích và chỉnh sửa giúp mình file chứa macro, mình mở file báo lỗi "Missing end Braket". Cám ơn bạn nhiều!

Code này được viết khi máy có cài đặt hệ ngôn ngữ Asia, nếu tôi không nhầm thì đó là tiếng Nhật.

Bây giờ bạn mang code đó sang máy không có hệ ngôn ngữ Asia thì sẽ báo lỗi.

Cách khắc phục: bạn cài đặt hệ ngôn ngữ Asia cho máy (Tiếng Nhật).

maint1311 · 2/2/16

Cám ơn bạn nhiều, mình đã làm theo hướng dẫn của bạn nhưng vẫn không được.

dhn46 · 2/2/16

maint1311 đã viết:
Cám ơn bạn nhiều, mình đã làm theo hướng dẫn của bạn nhưng vẫn không được.

Mình quên chưa nói với bạn là Office bạn sử dụng cũng phải là bản Nhật ngữ.

Trường hợp này mình đã gặp khá nhiều.

Code người Nhật viết hầu hết trên office, window tiếng Nhật của họ. Khi chuyển sang Việt Nam thì ngôn ngữ bị đảo lộn rất nhiều.

Bạn có thể Test trên 1 bản office tiếng Nhật để so sánh nhé.

lindanguyenkt2010 · 2/2/16

A ơi nếu như e mún tìm 1 content trong 1 file excel có nhiều sheet và content đó có cấu trúc giống nhau VD: SPOT P18-44|HA NOI

Và content nằm ở ô A1 của các sheet trong file NGUON
Chỉ khác nhau phần in đậm nghiêng thui thì dùng VBA bằng cách nào vậy a

E cám ơn a

lindanguyenkt2010 · 2/2/16

E gửi file mô tả nha anh

bkphong · 4/2/16

Gỡ rối code VBA

Private Sub CommandButton2_Click()
Dim cell As Range, r As Range
Dim cll As Range, s As Range
Dim ir As Long, ic As Long
Dim sodong As Integer

Application.ScreenUpdating = False
Application.Calculation = xlManual
Application.EnableEvents = False

Set r = Sheet4.Range("C59:C50000")
For Each cell In r.Cells
If cell.Value <> "" Then
ir = cell.Row: ir = ir + 1: ic = cell.Column
Do While Cells(ir, ic).Value <> ""
ir = ir + 1
Loop
ir = ir - 1
If Cells(ir, ic).Value <> "" And Cells(ir - 1, ic + 1).Value <> "" Then
For sodong = 1 To 54
Cells(ir, ic).EntireRow.Insert
' Selection.EntireRow.Insert
Next sodong
End If
End If
Next

Set s = Sheet4.Range("C59:C50000")
For Each cll In s.Cells
If cll.Value <> "" Then
Sheet4.Range("H4:AK58").Copy
Cells(cll.Row - 1, cll.Column + 5).Select
ActiveSheet.Paste
End If
Next

MsgBox "KET THUC CHEN BIEU MAU PHAN TICH DON GIA"
Application.Calculate
Application.ScreenUpdating = True
Application.Calculation = xlAutomatic
Application.EnableEvents = True

End Sub
Nhờ các cao thủ giải thích giúp mình đoạn mã trên với. thank you nhiều

doveandrose · 4/2/16

bkphong đã viết:
Nhờ các cao thủ giải thích giúp mình đoạn mã trên với. thank you nhiều

à cái này mình biết , nó là 1 đoạn code thực hiện bằng ngôn ngữ VBA đấy bạn

Kiều Mạnh · 21/2/16

Ngồi không Rảnh hơi quậy Bộ Office của Bác Bill ...Vô tình tìm thấy đoạn code sau...
Phải chăng Bác Bill sử dụng Dic để RemoveDuplicates

Code Như Sau bao gồm cả Ghi chú của Bác Bill

PHP:

'-------------------------------------------------------------------------------' RemoveDuplicates'' Remove duplicate entries from a one dimensional array'-------------------------------------------------------------------------------Function RemoveDuplicates(Array) Dim Item Dim dicNoDupes Set dicNoDupes = CreateObject("Scripting.Dictionary") For Each Item in Array If Not dicNoDupes.Exists(Item) Then dicNoDupes.Add Item, Item Next 'Item RemoveDuplicates = dicNoDupes.Keys End Function 'RemoveDuplicates

311280 · 22/2/16

Nhờ mod xóa giùm bài này.

hathien170170 · 24/2/16

______________________________________________________

12C7_CG · 24/2/16

Chào các bác
cho em hỏi là em có một macro A. Nếu A gặp sự kiện B có thể rẽ nhánh theo C,D,E,F (sử dụng useform lựa chọn tùy ý người dùng) còn không gặp B thì thực hiện bình thường.vậy làm thế nào để cái useform ấy nhận biến từ macro đang thực hiện vậy ạ.
em xin chân thành cảm ơn !

Lequocvan · 3/3/16

Em có code trong file sau ko thể nào lấy được số liệu của cả 3 sheet, chỉ lấy được khi em thay For I = 1 To 1 hoặc For I = 2 To 2 hoặc For I=3 To 3 ... như vậy nếu em có 31 sheet thì 31 lần thay thủ công. Mong các Thầy giúp cho ah!

Lequocvan · 3/3/16

Các Thầy ơi, em làm ra được rồi ah. Em làm được rồi, tại em không sắp xếp đúng trình tự, tuyệt cú mèo. thanks GPE.

dutrungkien · 6/3/16

Xin thân chào toàn thể các anh, chị, em giaiphapexcel. Kính chúc mọi người luôn được vui khỏe, hạnh phúc, vạn an. Tôi nay "có chút bối rối" mong được trợ giúp...Vừa qua các cháu nhà tôi cài lại Win 10, bộ office 2013 thì các bảng tính Excel của tôi báo lỗi như trong hình đính kèm. (Đoạn mã TachHoTen này trước đây tôi học được của anh PhamDuyLong trên giaiphapexcel mà tôi hằng yêu quý, nhân đây xin được cảm ơn anh Long nhiều lắm). Rất, rất mong được sự "giải cứu binh nhì..." (càng cụ thể càng tốt). Xin cảm ơn nhiều nhiều...

locphat6868 · 8/3/16

Chào ACE,
Mình có file excel VBA đính kèm bên dưới
Mình down file này từ GPE, nhưng mình muốn biết mã code VBA mà code này đã được đặt mật khẩu
Mình chỉ muốn tìm hiểu code VBA này thôi, mình muốn ứng dụng thêm chứ không có chủ đích xấu

mình chỉ học hỏi cách hoạt động của code này thôi, không có ý gì xấu hết

Mong ACE nào biết pass code VBA này thí giúp mình, còn không thì giải mã cho mình cũng được

Chân thành cảm ơn các ACE

hcminh2016 · 9/3/16

locphat6868 đã viết:
Chào ACE,
Mình có file excel VBA đính kèm bên dưới
Mình down file này từ GPE, nhưng mình muốn biết mã code VBA mà code này đã được đặt mật khẩu
Mình chỉ muốn tìm hiểu code VBA này thôi, mình muốn ứng dụng thêm chứ không có chủ đích xấu

mình chỉ học hỏi cách hoạt động của code này thôi, không có ý gì xấu hết

Mong ACE nào biết pass code VBA này thí giúp mình, còn không thì giải mã cho mình cũng được

Chân thành cảm ơn các ACE

Bạn làm gì mà 1 vấn đề của bạn lại đi hỏi ở 3 topic vậy?
-------------------------------------------------------------
Chưa kể hỏi Pass code VBA cũng là không đúng rồi...Bó tay cho bạn.

locphat6868 · 9/3/16

Nhờ A/C code giúp e với
VBA xuất từ excel sang pdf với điều kiện như sau:
Đặt tên file xuất sang pdf theo tên thay đổi theo giá trị tại ô G10 (G10 là giá trị nằm trong danh sách)
vd: Nếu ô G10 là A thì xuất đặt tên file pdf là A.pdf
Nếu ô G10 là B thì xuất đặt tên file pdf là B.pdf
Nếu ô G10 là C thì xuất đặt tên file pdf là C.pdf

Chân thành cám ơn

dtaphuong · 9/3/16

Nhờ mọi người coi dùm mình code trong Module 3 của file đính kèm.

Chức năng của đoạn code này là khi mình nhấn vào nút "update" thì thông tin được chỉnh sửa trên sheet "TraCuu" se tự động cập nhật vào sheet "Total".

Mấy tháng nay xài thì không sao, không biết hôm nay bị gì mà khi nhấn "Update", nó hiện lên báo lỗi tại dòng số 9

tracuu = [a4].CurrentRegion.value

Mong mọi người giúp đỡ

Cám ơn mọi người

Kiều Mạnh · 9/3/16

dtaphuong đã viết:
Nhờ mọi người coi dùm mình code trong Module 3 của file đính kèm.

Chức năng của đoạn code này là khi mình nhấn vào nút "update" thì thông tin được chỉnh sửa trên sheet "TraCuu" se tự động cập nhật vào sheet "Total".

Mấy tháng nay xài thì không sao, không biết hôm nay bị gì mà khi nhấn "Update", nó hiện lên báo lỗi tại dòng số 9

tracuu = [a4].CurrentRegion.value

Mong mọi người giúp đỡ

Cám ơn mọi người

Bạn thử xóa Cells B17 ... Sheets("tracuu

đi coi xong chạy code là thấy lỗi do cái Gì

ChanhTQ@ · 9/3/16

dtaphuong đã viết:
Nhờ mọi người coi dùm mình code trong Module 3 của file đính kèm.

tracuu = [a4].CurrentRegion.value

Mình luôn dị ứng với cách viết Code của bạn (Hay của người nào đã giúp)

Hiện tại macro của bạn có tên là 'tracuu' lại trùng với tên 1 biến đã khai báo. Làm chuyện như vậy làm chi vậy?
Mà Tên macro hay tên biến cũng nên viết 'TraCuu' có ngứa mắt với bạn chăng?
Nếu bạn sửa tên macro theo mình đề xuất; Lúc đó tên biến cũng đổi theo, => 'TraCuu' cho mà xem!

Với mình bao giờ cũng có câu Option Explicit ở trong chương trình.
Khai báo biến cũng nên tường minh; Hơn nữa, biến cùng loại nên để trên cùng dòng cho dễ trong quản lí & sử dụng.
Ví dụ:

PHP:

Dim Arr(), Sh As Object, Rng As Range
Dim J as long, Rws As Long
Dim StrC As String

Làm vậy cũng chả ai dám đánh giá thập khả năng BVA của bạn cả!

dtaphuong · 9/3/16

Cám ơn bạn nhiều nha, mình không có xóa cells B17, chỉ định dạng lại nó thành general thì nó không báo lỗi nữa.

Nhưng mà bây giờ code vba đó không chạy được, mình nhấn nút update thì nó vẫn báo là update rồi, nhưng mà thực tế là không có thông tin

kieu manh đã viết:
Bạn thử xóa Cells B17 ... Sheets("tracuu đi coi xong chạy code là thấy lỗi do cái Gì

dtaphuong · 9/3/16

ChanhTQ@ đã viết:
Mình luôn dị ứng với cách viết Code của bạn (Hay của người nào đã giúp)

Hiện tại macro của bạn có tên là 'tracuu' lại trùng với tên 1 biến đã khai báo. Làm chuyện như vậy làm chi vậy?
Mà Tên macro hay tên biến cũng nên viết 'TraCuu' có ngứa mắt với bạn chăng?
Nếu bạn sửa tên macro theo mình đề xuất; Lúc đó tên biến cũng đổi theo, => 'TraCuu' cho mà xem!

Với mình bao giờ cũng có câu Option Explicit ở trong chương trình.
Khai báo biến cũng nên tường minh; Hơn nữa, biến cùng loại nên để trên cùng dòng cho dễ trong quản lí & sử dụng.
Ví dụ:

PHP:

Dim Arr(), Sh As Object, Rng As Range Dim J as long, Rws As Long Dim StrC As String

Làm vậy cũng chả ai dám đánh giá thập khả năng BVA của bạn cả!

Cám ơn bạn góp ý. Code này là mình được giúp nên mình giữ nguyên luôn

huongchuoi · 11/3/16

Em xin chào các cao thủ. Em đang có 1 vấn đề rắc rối mong mọi người tháo gỡ giúp em.
Em có 1 data gồm các cột :life number, policy number, inception date, sum assured, risk type. Có 5 loại risk type mỗi một life number có thể có 1 hoặc nhiều risk type. Giờ em muốn copy những dòng life number có cùng risk type mà tổng sum assured lớn hơn 800 triệu với điều kiện tháng inception date được cộng dồn. Tức là inception date bắt đầu từ tháng 12/2014 sẽ copy data của những life number có cùng 1 risk type trong tháng 12 mà tổng sum lớn hơn 800 là 1 kết quả. Sau đó, đến tháng 1/2015 có thể life number của tháng 12 /2014 sẽ xuất hiện lại ở tháng 1 thì phải lấy lại những dòng đó với điều kiện như trên và copy hết vào tháng 1. Có thể có những life chưa xuất hiện trong sheet kết quả của tháng 12 nhưng đến tháng 1 lại có vì lúc này tổng tiền cộng dồn trên 1 risk của life này đã lớn hơn 800 vì tháng 1 có phát sinh thêm cùng risk đó.

Đại loại dữ liệu trong sheet "Data" và kết quả ở 2 sheets "12-2014" và "1-2015".

mong các cao thủ vba giúp em với ah.

em xin chân thành cám ơn

duongcga · 12/3/16

@ChanhTQ: mỗi người có một phong cách viết code khác nhau mà bạn, nhưng càng ngắn ngọn, xúc tích, nghĩa rõ ràng càng tốt. chứ ko nhất thiết phải theo ai.
Dim Arr(), Sh As Object, Rng As Range
Dim J as long, Rws As Long
Dim StrC As String
Bạn đưa ra ví dụ ở trên, nói thật mình chưa thấy ai dùng phong cách khai báo biến như bạn, chắc đó là phong cách của bạn thôi. Thường mình thấy mọi người khai báo biến dùng định dạng lạc đà (camel), còn hàm thì dùng kiểu pascal...

comeonnow · 12/3/16

Em có dữ liệu đầu vào là A1, A2, B1, B2, C, D1, D2, E1, E2, F1, F2, F3, G1, G2. Em cần tách làm 2 trường hợp từ A1 - E2 và từ F1 - G2.
Em sử dụng Select Case như nhau:

PHP:

Select Case R_4.Value
Case "A1" Or "A2" Or "B1" Or "B2" Or "C" Or "D1" Or "D2"                     
            If R_1.Value = "CU" Then                    
                Select Case R_3.Value
                    Case 2
                        cData = .Range("A4:H20").Value   
                    Case 3
                        cData = .Range("K4:R20").Value   
                End Select
            Else                                        
                Select Case R_3.Value
                    Case 2
                        cData = .Range("A21:H36").Value   
                    Case 3
                        cData = .Range("K21:R36").Value   
                End Select
            End If
Case Else                                       
If R_1.Value = "CU" Then
               cData = .Range("A8:H27").Value           
           Else
               cData = .Range("A28:H46").Value          
           End If
End Select

Chạy thì báo lỗi, em đoán là do Case của em không đúng, nhưng không biết sửa như thế nào?

phihndhsp · 12/3/16

duongcga đã viết:
@ChanhTQ: mỗi người có một phong cách viết code khác nhau mà bạn, nhưng càng ngắn ngọn, xúc tích, nghĩa rõ ràng càng tốt. chứ ko nhất thiết phải theo ai.
Dim Arr(), Sh As Object, Rng As Range
Dim J as long, Rws As Long
Dim StrC As String
Bạn đưa ra ví dụ ở trên, nói thật mình chưa thấy ai dùng phong cách khai báo biến như bạn, chắc đó là phong cách của bạn thôi. Thường mình thấy mọi người khai báo biến dùng định dạng lạc đà (camel), còn hàm thì dùng kiểu pascal...

Đúng là mỗi người có 1 cách viết, nhưng cách viết nào rõ ràng, tường minh thì dễ kiểm soát hơn rất nhiều so với cách viết không tường minh, không phải ngắn gọn là tối ưu đâu nha bạn," cái này bạn sẽ biết rõ nếu bạn đã học lập trình cơ sở", kiến thức thực hành là kinh nghiệm thực tiễn, nên những thành viên gạo cội ở đây khuyên thì bạn nên nghĩ lại mà học hỏi, tôi chỉ nói như vậy thôi, học hỏi hay không tùy bạn

phihndhsp · 12/3/16

comeonnow đã viết:
Em có dữ liệu đầu vào là A1, A2, B1, B2, C, D1, D2, E1, E2, F1, F2, F3, G1, G2. Em cần tách làm 2 trường hợp từ A1 - E2 và từ F1 - G2.

tách 2 trường hợp thì làm như thế này xem sao

PHP:

Select Case Range("a1").Value

Case "A1" To "C2", "E1" To "F1"     
 .............
Case Else
   .................
End Select

comeonnow · 12/3/16

phihndhsp đã viết:
tách 2 trường hợp thì làm như thế này xem sao

PHP:

Select Case Range("a1").Value Case "A1" To "F1" ............. Case Else ................. End Select

Case "A1" To "F1" thì nó có bao gồm F1 ko nhỉ? VBA nhận biết được thứ tự A1, A2, B1, B2 hả bác? Em tưởng nó là kiểu ký tự nên phải kê hết ra

Còn nếu 2 trường hợp lại là D1, D2 và phần còn lại (tách ở giữa) thì viết như thế nào bác phihndhsp

phihndhsp · 12/3/16

bạn xem lại bài 488 nha, vì tôi không đọc kỹ đề là thằng D1 và D2 tách riêng

Hau151978 · 12/3/16

phihndhsp đã viết:
Đúng là mỗi người có 1 cách viết, nhưng cách viết nào rõ ràng, tường minh thì dễ kiểm soát hơn rất nhiều so với cách viết không tường minh, không phải ngắn gọn là tối ưu đâu nha bạn," cái này bạn sẽ biết rõ nếu bạn đã học lập trình cơ sở", kiến thức thực hành là kinh nghiệm thực tiễn, nên những thành viên gạo cội ở đây khuyên thì bạn nên nghĩ lại mà học hỏi, tôi chỉ nói như vậy thôi, học hỏi hay không tùy bạn

Bác ChanhTQ khi nói hàm TraCuu đó là cách đặt tên hỗn hợp cả chữ hoa và chữ thường, đó cũng là cách đặt tên kiểu lạc đà hay kiểu Pascal như bạn duongca đã viết nhưng ví dụ ở dưới của bác Chanh thì lại không như vậy. Cách viết này cũng có thể phối hợp với đặt tên kiểu Hungary nữa.

comeonnow · 12/3/16

Báo lỗi ở .Range

Em viết bị lỗi như trên, không biết là bị làm sao...
Module 1 của em cũng dùng cấu trúc như này, nhưng để tính chọn dây nên phải chọn theo sheet, chạy OK
Em viết thêm Module 2 để hiệu chỉnh theo nhiệt độ, chỉ chọn dữ liệu trong 1 sheet nên em để tData = .Range("B_52_14_15!E4:G19").Value không hiểu sao lại bị lỗi #VALUE!

PS: GPE viết cmt thi thoảng cứ bị đẩy lên đầu dòng khi gõ dấu là bị sao nhỉ :3

phihndhsp · 12/3/16

comeonnow đã viết:
View attachment 155953
Em viết bị lỗi như trên, không biết là bị làm sao...
Module 1 của em cũng dùng cấu trúc như này, nhưng để tính chọn dây nên phải chọn theo sheet, chạy OK
Em viết thêm Module 2 để hiệu chỉnh theo nhiệt độ, chỉ chọn dữ liệu trong 1 sheet nên em để tData = .Range("B_52_14_15!E4:G19").Value không hiểu sao lại bị lỗi #VALUE!

PS: GPE viết cmt thi thoảng cứ bị đẩy lên đầu dòng khi gõ dấu là bị sao nhỉ :3

tData = .Range("B_52_14_15!E4:G19").Value
Cấu trúc không đúng nha bạn
tData = sheets("B_52_14_15").range("E4:G19").VALUE

comeonnow · 12/3/16

phihndhsp đã viết:
tData = .Range("B_52_14_15!E4:G19").Value
Cấu trúc không đúng nha bạntData = sheets("B_52_14_15").range("E4:G19").VALUE

Bác cho em hỏi cái chia trường hợp ở trên, vì sao không sử dụng Or trong Case được nhỉ?

phihndhsp · 12/3/16

comeonnow đã viết:
Bác cho em hỏi cái chia trường hợp ở trên, vì sao không sử dụng Or trong Case được nhỉ?

Bạn sử dụng cấu trúc sai
Case "D1", "D2"

comeonnow · 12/3/16

phihndhsp đã viết:
Bạn sử dụng cấu trúc sai
Case "D1", "D2"

Thanks bác Phihndhsp!

Em gặp phải trường hợp chia case như hình đính kèm
“Hệ thống máng cáp có đục lỗ nằm ngang” – “Hệ thống máng cáp có đục lỗ thẳng đứng”
VBA không hỗ trợ tiếng việt có dấu, mà sheet nhập của em sử dụng Data Valadition chọn trong list các trường hợp này.
Em cũng tham khảo Cách đánh TIẾNG VIỆT (Có dấu) trong cửa số soạn thảo VBA thì thấy nó hơi phức tạp.

SA_DQ · 12/3/16

Em có 1 data gồm các cột :life number, policy number, inception date, sum assured, risk type. Có 5 loại risk type mỗi một life number có thể có 1 hoặc nhiều risk type. Giờ em muốn copy những dòng life number có cùng risk type mà tổng sum assured lớn hơn 800 triệu với điều kiện tháng inception date được cộng dồn. Tức là inception date bắt đầu từ tháng 12/2014 sẽ copy data của những life number có cùng 1 risk type trong tháng 12 mà tổng sum lớn hơn 800 là 1 kết quả. Sau đó, đến tháng 1/2015 có thể life number của tháng 12 /2014 sẽ xuất hiện lại ở tháng 1 thì phải lấy lại những dòng đó với điều kiện như trên và copy hết vào tháng 1. Có thể có những life chưa xuất hiện trong sheet kết quả của tháng 12 nhưng đến tháng 1 lại có vì lúc này tổng tiền cộng dồn trên 1 risk của life này đã lớn hơn 800 vì tháng 1 có phát sinh thêm cùng risk đó.

Mình làm mới 1 trang tính thôi; để bạn kiểm tra số liệu;
Sau đó chúng ta sẽ tiếp với fần giống tương đương

duongcga · 12/3/16

@phihndhsp bạn không nhìn và đọc kỹ ah, quên là mình nói càng ngắn gọn, xúc tích càng tốt ah, hơn nữa bạn quên là còn có chú thích trong mã nguồn, description cho những method khi đã biên dịch. Phong cách lập trình là của mỗi ng, của cty hay nơi làm việc, tốt nhất cho mình thì dùng nhé. Bạn nên nhớ thành viên gạo cội chưa chắc đã cho lời khuyên tốt nhé.

@Còn những bạn nào đang bắt đầu lập trình, các bạn nên đọc cuốn sách hay và kinh điển này nhé 'Code complete' của 1 chuyên gia đến từ Microsoft.

duongcga · 13/3/16

@Hau151978 , viết theo kiểu Hungary , mình thấy lập trình viên của Microsoft C++/API rất hay dùng, nó rất ý nghĩa. thấy đội FPT cũng hay dùng.

huongchuoi · 14/3/16

SA_DQ đã viết:
Mình làm mới 1 trang tính thôi; để bạn kiểm tra số liệu;
Sau đó chúng ta sẽ tiếp với fần giống tương đương

Mình cám ơn bạn nhưng kết quả ở sheets "12-2014" trả ra chưa đúng với kết quả mình mong muốn.

Kết quả mong muốn là:
- tại sheets "12-2014" chỉ có các dòng có sum assured lớn hơn 800 hoặc tổng các hợp đồng cùng 1 life cùng 1 risk có sum assured lớn hơn 800 CỦA THÁNG 12 thì được xuất hiện. trong sheets kết quả bạn hiện ra có cả những tháng khác của năm 2015.
- tại các sheets tiếp theo như "1-2015","2-2015","3-2015",....."12-2015", tương tự quy tắc như trên nhưng lấy lại cả những dòng của tháng 12 nữa. và nếu life nào tháng 12 chưa xuất hiện do sum assured chưa đủ 800 mà đến tháng 1 life này xuất hiện thêm risk nào đó làm cho sum assured trên 800 thì sẽ ghi nhận cả tháng 12 và tháng 1. Những tháng sau nó chưa ghi vào

cám ơn bạn

Lequocvan · 14/3/16

Nhờ các sư phụ chỉ giúp cách tìm kiếm không chỉ 1 giá trị trong GtriTK ah:
Em muốn GtriTK = "519101" và "519103" và "519106" mà ko biết sửa code sau như thế nào ah?

Sub CopyRow_519101_103_106()

Dim tenWsVBA, tenWs As String
tenWsVBA = ActiveSheet.CodeName
tenWs = ActiveSheet.Name

Dim Ws As Worksheet
For Each Ws In ThisWorkbook.Worksheets

If Ws.Name = "Sheet1n" Then

Ws.Select

End If

Next

Dim rng As Range, GtriTK As String
GtriTK = "519101"
With Worksheets(tenWs).Range("B1:B" & Range("B1000").End(xlUp).Row)

Set rng = .Find(GtriTK, LookIn:=xlValues)
If Not rng Is Nothing Then rng.Activate
ActiveCell.EntireRow.Select
'ActiveCell.EntireRow.Interior.ColorIndex = 8
Selection.Copy

End With

End Sub
Thanks. Em đã tìm ra giải pháp.

311280 · 14/3/16

Sau khi gán marco, save lại thì báo lỗi như hình là sao vậy các bác. Nhấn Yes, tắt file mở lại thì mất hết marco. Chân thành cảm ơn.

Ba Tê · 14/3/16

311280 đã viết:
View attachment 156022
Sau khi gán marco, save lại thì báo lỗi như hình là sao vậy các bác. Nhấn Yes, tắt file mở lại thì mất hết marco. Chân thành cảm ơn.

Nếu trong file có Macros, bạn phải chọn lưu kiểu .xlsm , nếu lưu .xlsx thì nó không mang Macros "trong mình" được.

comeonnow · 14/3/16

Em có 2 ô sử dụng Data Validation [B1] và [B5],
khi [B1] có giá trị E1 hoặc E2 thì [B5] có giá trị "Touching" hoặc "Spaced".
Khi [B1] ko có giá trị E1, E2 như trên thì ô [B5] vẫn lưu giá trị trước đó, và ko chọn được list.

Em thêm vào hàm IF trong Data Validation

PHP:

 =IF(OR($B$1="E1",$B$1="E2"),GPE!$E$28:$F$28,GPE!$G$30)

Thì nó ra list có ô trắng (Blank) nhưng lại không chọn được, không hiểu do bị sao nhưng file khác làm như vậy vẫn chọn được dòng trắng đó. (ý này chỉ là phụ)

Em đang cần ô [B5] tự động blank khi [B1] khác E1, E2
Em thử dòng lệnh VBA theo gợi ý của bác giaiphap:

PHP:

Private Sub Worksheet_Change(ByVal Target As Range)
If (Target.Address = "$B$1") And (Target.Value = "F2") Then [b5].Value = " "
End Sub

không thấy có tác dụng.

Các bác xem có cách nào, khi chọn giá trị khác E1, E2 trong [B1] (giả sử bằng "F2") thì ô [B5] tự động xóa lựa chọn cũ => blank được không ?

Excel365 · 15/3/16

Em có hàm như bên dưới, bây giờ em muốn them điều kiện dựa vào Bô phận sản xuất để xác định ngày nghỉ theo từng bộ phận sản xuất.
VD: Bộ phận sản xuất: thì có Ngày công chuẩn sản xuất - Ngày thực tế,
Bộ phận Văn phòng: thì có Ngày công chuẩn Văn phòng - Ngày thực tế,
..........
[NOTE1]Function Thuong(Byval NgayCongThucTe As Single, ByVal DK_Xet As String, Byval MucThuong As Double) Dim NgayNghi As Double
NgayNghi = NgayCongChuan - NgayCongThucTe
' Xac dinh ngay cong chuan dua vao Bo phan san xuat
If NgayNghi >= 14 Then
Thuong = 0
ElseIf NgayCongThucTe <= 20 Then
Select Case DK_Xet
Case Is = "OK"
Thuong = MucThuong
Case Else
Thuong = 0
End Select
ElseIf NgayCongThucTe >= 21 Then
Thuong = MucThuong
Else
Thuong = 0
End If
End Function

[/NOTE1]

Trân trọng cảm ơn
http://www.mediafire.com/download/neu2y77g52gyh0d/Thuong.xlsm

Chuyên mục xử lý, gỡ rối code VBA (2 người xem)

Người dùng đang xem chủ đề này

Huyền thoại GPE

Thành viên mới

Thành viên gạo cội

Thành viên mới

Thành viên mới

Thành viên mới

I don't program, I beat code into submission!!!

File đính kèm

Thành viên gạo cội

I don't program, I beat code into submission!!!

Thành viên mới

I don't program, I beat code into submission!!!

File đính kèm

Thành viên gạo cội

Thành viên mới

I don't program, I beat code into submission!!!

Thành viên mới

I don't program, I beat code into submission!!!

Thành viên mới

I don't program, I beat code into submission!!!

Thành viên mới

Thành viên mới

Thành viên hoạt động

Thành viên tiêu biểu

Cạo Rồi Khỏi Gội

Thành viên hoạt động

Thành viên tiêu biểu

Thành viên hoạt động

Cạo Rồi Khỏi Gội

Thành viên hoạt động

Cạo Rồi Khỏi Gội

Thành viên thường trực

Thành viên mới

Thành viên gạo cội

Thành viên mới

Thành viên mới

File đính kèm

Thành viên mới

hello

Thành viên mới

Thành viên thường trực

Huyền thoại GPE

Thành viên thường trực

hello

Đang đi tìm hòn đá

Thành viên mới

File đính kèm

Thành viên gắn bó

Thành viên mới

Thành viên chính thức

Thành viên gắn bó

I don't program, I beat code into submission!!!

Thành viên chính thức

Thành viên thường trực

Chuyên gia GPE

Thành viên mới

File đính kèm

Busy

Thành viên tích cực

Thành viên tích cực

Thành viên mới

File đính kèm

Thành viên mới

File đính kèm

Hướng tới tương lai

Thành viên mới

Hướng tới tương lai

Thành viên mới

Thành viên mới

File đính kèm

Thành viên mới

hello

I don't program, I beat code into submission!!!

Thành viên hoạt động

Thành viên mới

Thành viên mới