Code lỗi phiên bản excel (1 người xem)

Liên hệ QC

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

Đang trực tuyến: 1 (Thành viên: 0, Khách: 1)
P

phuocrobe

Thành viên hoạt động
Tham gia
2/11/16
Bài viết
131
Được thích
0
Mình có đoạn code này khi chạy trên excel 2010 thì chạy bình thường nhưng khi chạy trên excel 2003 thì bị lỗi "Provider cannot be found. It may not be properly installed". Nhờ các anh chị xử lý giúp em làm sao để có thể chạy trên excel 2003 được à. Em xin cám ơn -=.,,-=.,,
Sub doichieuketoan()
Application.ScreenUpdating = False
Range("A6:G" & Range("A65000").End(3).Row + 1).ClearContents
Set cn = CreateObject("ADODB.Connection")
cn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & ThisWorkbook.Path & "\ketoan.xls;Extended Properties=""Excel 12.0 Xml;HDR=NO;IMEX=1"";"
Range("A6").CopyFromRecordset cn.Execute("SELECT f5,f7,f8,f15,f22,f30 FROM [doc1$A15:AK60000] where f2 >0")
Range("A6:A" & Range("A65000").End(3).Row).Value = "=row()-5"
Range("A6:G" & Range("A65000").End(3).Row).Borders.LineStyle = xlContinuous
Range("A6:G60000").Select
ActiveWorkbook.Worksheets("B07").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("B07").Sort.SortFields.Add Key:=Range( _
"C6:C60000"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
xlSortNormal
ActiveWorkbook.Worksheets("B07").Sort.SortFields.Add Key:=Range( _
"B6:B60000"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
xlSortNormal
With ActiveWorkbook.Worksheets("B07").Sort
.SetRange Range("A5:G60000")
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
End Sub
Nhấp chuột vào đây để mở rộng...
 

File đính kèm

Lần chỉnh sửa cuối:
Sắp xếp theo thời gian sắp xếp theo bầu chọn
FilePath = "=" & Fullpath & "A10:EU" & Rows(1).End(2)
Nó báo lỗi dòng này bạn à, vì lúc trước code này mình nhờ người khác code chứ mình còn gà lắm à.
winvista đã viết:
Ở dòng nào đoạn code nào, tình huống nào? nên mô tả chi tiết?
Vì tôi không có excel 2003 nữa, nên e rằng test cũng bằng 0
Nhấp chuột vào đây để mở rộng...
 
Upvote 0
Code này mình dùng để lọc dữ liệu từ file khác để phục vụ cho công việc thôi à.
winvista đã viết:
trên đã viết


Tuy vậy, tôi cố đọc qua code của bạn, thì code đó quá nhiều thứ tồn tại

- code cố gắng dùng công thức để link , lấy dữ liệu từ file TongHop
- code dùng vùng tạm và cell IV1 để lưu các thông tin
- code tự làm rắc rối nhiều vấn đề

tuy nhiên, tôi không hiểu mục tiêu của code bạn làm chi?
Nhấp chuột vào đây để mở rộng...
 
Upvote 0
thế thử đại thế này đi, giữ nguyên thuật toán , chỉ sửa cho qua lỗi

PHP: 
Public Sub TDNH()
    Application.ScreenUpdating = False
  
    Dim Res(), Arr(), i As Long, j As Long, k As Long, Fullpath As String, FilePath As String, celIU As Range
    Set celIU = [IU1]
    Fullpath = "'" & ThisWorkbook.Path & "\[TongHop.xls]THA'!"
    With celIU
        .Formula = "=IF(ISERROR(LOOKUP(2,1/(" & Fullpath & "A1:A65536<>""""),ROW(1:65536))),0,LOOKUP(2,1/(" & Fullpath & "A1:A65536<>""""),ROW(1:65536)))"
        .Value = .Value
    End With
    
    FilePath = "=" & Fullpath & "A10:EU" & celIU.Value
    With Range("B15").Resize(celIU.Value - 10 + 1, 151)
        .FormulaArray = FilePath
        Res = .Value
        .ClearContents
    End With
    

    ReDim Preserve Arr(1 To UBound(Res), 1 To 12)
    For i = 1 To UBound(Res)
        If Res(i, 129) <> Empty Then
            k = k + 1
            Arr(k, 1) = k
            For j = 10 To 13
                Arr(k, j - 8) = Res(i, j)
            Next
            Arr(k, 6) = Res(i, 129)
            Arr(k, 7) = Res(i, 2)
            Arr(k, 8) = Res(i, 31)
            
            Arr(k, 9) = Res(i, 40) + Res(i, 49) + Res(i, 59) + Res(i, 66)
            Arr(k, 10) = Res(i, 91)
            Arr(k, 12) = Res(i, 130)
            If Res(i, 98) = 1 Then Arr(k, 11) = Range("Nguyen_nhan!B3")
            If Res(i, 99) = 1 Then Arr(k, 11) = Range("Nguyen_nhan!B4")
            If Res(i, 100) = 1 Then Arr(k, 11) = Range("Nguyen_nhan!B5")
            If Res(i, 101) = 1 Then Arr(k, 11) = Range("Nguyen_nhan!B6")
            If Res(i, 102) = 1 Then Arr(k, 11) = Range("Nguyen_nhan!B7")
            If Res(i, 103) = 1 Then Arr(k, 11) = Range("Nguyen_nhan!B8")
            If Res(i, 105) = 1 Then Arr(k, 11) = Range("Nguyen_nhan!B9")
            If Res(i, 89) = 1 Then Arr(k, 11) = Range("Nguyen_nhan!B10")
            If Res(i, 89) = 2 Then Arr(k, 11) = Range("Nguyen_nhan!B11")
            If Res(i, 106) = 1 Then Arr(k, 11) = Range("Nguyen_nhan!B12")
         End If
    Next
    If k Then Range("A10").Resize(k, 12).Value = Arr
    celIU.ClearContents
    Application.ScreenUpdating = True
End Sub
 
Upvote 0
Mình chạy lại code như của bạn nhưng vẫn không được bạn à.
Nó bị lỗi dòng này à. "With Range("B15").Resize(celIU.Value - 10 + 1, 151)"
winvista đã viết:
thế thử đại thế này đi, giữ nguyên thuật toán , chỉ sửa cho qua lỗi

PHP: 
Public Sub TDNH()
    Application.ScreenUpdating = False
  
    Dim Res(), Arr(), i As Long, j As Long, k As Long, Fullpath As String, FilePath As String, celIU As Range
    Set celIU = [IU1]
    Fullpath = "'" & ThisWorkbook.Path & "\[TongHop.xls]THA'!"
    With celIU
        .Formula = "=IF(ISERROR(LOOKUP(2,1/(" & Fullpath & "A1:A65536<>""""),ROW(1:65536))),0,LOOKUP(2,1/(" & Fullpath & "A1:A65536<>""""),ROW(1:65536)))"
        .Value = .Value
    End With
    
    FilePath = "=" & Fullpath & "A10:EU" & celIU.Value
    With Range("B15").Resize(celIU.Value - 10 + 1, 151)
        .FormulaArray = FilePath
        Res = .Value
        .ClearContents
    End With
    

    ReDim Preserve Arr(1 To UBound(Res), 1 To 12)
    For i = 1 To UBound(Res)
        If Res(i, 129) <> Empty Then
            k = k + 1
            Arr(k, 1) = k
            For j = 10 To 13
                Arr(k, j - 8) = Res(i, j)
            Next
            Arr(k, 6) = Res(i, 129)
            Arr(k, 7) = Res(i, 2)
            Arr(k, 8) = Res(i, 31)
            
            Arr(k, 9) = Res(i, 40) + Res(i, 49) + Res(i, 59) + Res(i, 66)
            Arr(k, 10) = Res(i, 91)
            Arr(k, 12) = Res(i, 130)
            If Res(i, 98) = 1 Then Arr(k, 11) = Range("Nguyen_nhan!B3")
            If Res(i, 99) = 1 Then Arr(k, 11) = Range("Nguyen_nhan!B4")
            If Res(i, 100) = 1 Then Arr(k, 11) = Range("Nguyen_nhan!B5")
            If Res(i, 101) = 1 Then Arr(k, 11) = Range("Nguyen_nhan!B6")
            If Res(i, 102) = 1 Then Arr(k, 11) = Range("Nguyen_nhan!B7")
            If Res(i, 103) = 1 Then Arr(k, 11) = Range("Nguyen_nhan!B8")
            If Res(i, 105) = 1 Then Arr(k, 11) = Range("Nguyen_nhan!B9")
            If Res(i, 89) = 1 Then Arr(k, 11) = Range("Nguyen_nhan!B10")
            If Res(i, 89) = 2 Then Arr(k, 11) = Range("Nguyen_nhan!B11")
            If Res(i, 106) = 1 Then Arr(k, 11) = Range("Nguyen_nhan!B12")
         End If
    Next
    If k Then Range("A10").Resize(k, 12).Value = Arr
    celIU.ClearContents
    Application.ScreenUpdating = True
End Sub
Nhấp chuột vào đây để mở rộng...
 
Upvote 0
phuocrobe đã viết:
Mình còn gà lắm nên bạn thông cảm nha. Nó báo lỗi thế này đây:
Run-time error '1004':
Application-defined or object-defined error
Nhấp chuột vào đây để mở rộng...
thế thử em này, cho kết quả?
PHP: 
Public Sub TDNH()

    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
  
    Dim Res(), Arr(), i As Long, j As Long, k As Long, Fullpath As String, FilePath As String, celIU As Range
    Dim Ws As Worksheet
    
    
    Fullpath = "'" & ThisWorkbook.Path & "\[TongHop.xls]THA'!"
    
    Set Ws = ThisWorkbook.Sheets.Add
    Set celIU = Ws.[A1]
    With celIU
        .Formula = "=IF(ISERROR(LOOKUP(2,1/(" & Fullpath & "A1:A65536<>""""),ROW(1:65536))),0,LOOKUP(2,1/(" & Fullpath & "A1:A65536<>""""),ROW(1:65536)))"
        .Value = .Value
    End With
    
    FilePath = "=" & Fullpath & "A10:EU" & celIU.Value
    With Ws.Range("A10").Resize(celIU.Value - 9, 151)
        .FormulaArray = FilePath
        Res = .Value
        .ClearContents       
    End With
    Ws.Delete

    ReDim Preserve Arr(1 To UBound(Res), 1 To 12)
    For i = 1 To UBound(Res)
        If Res(i, 129) <> Empty Then
            k = k + 1
            Arr(k, 1) = k
            For j = 10 To 13
                Arr(k, j - 8) = Res(i, j)
            Next
            Arr(k, 6) = Res(i, 129)
            Arr(k, 7) = Res(i, 2)
            Arr(k, 8) = Res(i, 31)
            
            Arr(k, 9) = Res(i, 40) + Res(i, 49) + Res(i, 59) + Res(i, 66)
            Arr(k, 10) = Res(i, 91)
            Arr(k, 12) = Res(i, 130)
            If Res(i, 98) = 1 Then Arr(k, 11) = Range("Nguyen_nhan!B3")
            If Res(i, 99) = 1 Then Arr(k, 11) = Range("Nguyen_nhan!B4")
            If Res(i, 100) = 1 Then Arr(k, 11) = Range("Nguyen_nhan!B5")
            If Res(i, 101) = 1 Then Arr(k, 11) = Range("Nguyen_nhan!B6")
            If Res(i, 102) = 1 Then Arr(k, 11) = Range("Nguyen_nhan!B7")
            If Res(i, 103) = 1 Then Arr(k, 11) = Range("Nguyen_nhan!B8")
            If Res(i, 105) = 1 Then Arr(k, 11) = Range("Nguyen_nhan!B9")
            If Res(i, 89) = 1 Then Arr(k, 11) = Range("Nguyen_nhan!B10")
            If Res(i, 89) = 2 Then Arr(k, 11) = Range("Nguyen_nhan!B11")
            If Res(i, 106) = 1 Then Arr(k, 11) = Range("Nguyen_nhan!B12")
         End If
    Next
    If k Then Range("A10").Resize(k, 12).Value = Arr
    
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
End Sub
 
Upvote 0
Nó vẫn báo lỗi dòng này: With Ws.Range("A10").Resize(celIU.Value - 9, 151)
Run-time error '1004':
Application-defined or object-defined error
Mỗi lần chạy code là nó tạo 1 sheet mới. Bạn bỏ cái này ra giúp mình luôn với vì như thế thì khi dùng sẽ tạo ra quá nhiều sheet luôn à. Cám ơn bạn nhiều nha.

winvista đã viết:
thế thử em này, cho kết quả?
PHP: 
Public Sub TDNH()

    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
  
    Dim Res(), Arr(), i As Long, j As Long, k As Long, Fullpath As String, FilePath As String, celIU As Range
    Dim Ws As Worksheet
    
    
    Fullpath = "'" & ThisWorkbook.Path & "\[TongHop.xls]THA'!"
    
    Set Ws = ThisWorkbook.Sheets.Add
    Set celIU = Ws.[A1]
    With celIU
        .Formula = "=IF(ISERROR(LOOKUP(2,1/(" & Fullpath & "A1:A65536<>""""),ROW(1:65536))),0,LOOKUP(2,1/(" & Fullpath & "A1:A65536<>""""),ROW(1:65536)))"
        .Value = .Value
    End With
    
    FilePath = "=" & Fullpath & "A10:EU" & celIU.Value
    With Ws.Range("A10").Resize(celIU.Value - 9, 151)
        .FormulaArray = FilePath
        Res = .Value
        .ClearContents       
    End With
    Ws.Delete

    ReDim Preserve Arr(1 To UBound(Res), 1 To 12)
    For i = 1 To UBound(Res)
        If Res(i, 129) <> Empty Then
            k = k + 1
            Arr(k, 1) = k
            For j = 10 To 13
                Arr(k, j - 8) = Res(i, j)
            Next
            Arr(k, 6) = Res(i, 129)
            Arr(k, 7) = Res(i, 2)
            Arr(k, 8) = Res(i, 31)
            
            Arr(k, 9) = Res(i, 40) + Res(i, 49) + Res(i, 59) + Res(i, 66)
            Arr(k, 10) = Res(i, 91)
            Arr(k, 12) = Res(i, 130)
            If Res(i, 98) = 1 Then Arr(k, 11) = Range("Nguyen_nhan!B3")
            If Res(i, 99) = 1 Then Arr(k, 11) = Range("Nguyen_nhan!B4")
            If Res(i, 100) = 1 Then Arr(k, 11) = Range("Nguyen_nhan!B5")
            If Res(i, 101) = 1 Then Arr(k, 11) = Range("Nguyen_nhan!B6")
            If Res(i, 102) = 1 Then Arr(k, 11) = Range("Nguyen_nhan!B7")
            If Res(i, 103) = 1 Then Arr(k, 11) = Range("Nguyen_nhan!B8")
            If Res(i, 105) = 1 Then Arr(k, 11) = Range("Nguyen_nhan!B9")
            If Res(i, 89) = 1 Then Arr(k, 11) = Range("Nguyen_nhan!B10")
            If Res(i, 89) = 2 Then Arr(k, 11) = Range("Nguyen_nhan!B11")
            If Res(i, 106) = 1 Then Arr(k, 11) = Range("Nguyen_nhan!B12")
         End If
    Next
    If k Then Range("A10").Resize(k, 12).Value = Arr
    
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
End Sub
Nhấp chuột vào đây để mở rộng...
 
Upvote 0
phuocrobe đã viết:
Nó vẫn báo lỗi dòng này: With Ws.Range("A10").Resize(celIU.Value - 9, 151)
Run-time error '1004':
Application-defined or object-defined error
Mỗi lần chạy code là nó tạo 1 sheet mới. Bạn bỏ cái này ra giúp mình luôn với vì như thế thì khi dùng sẽ tạo ra quá nhiều sheet luôn à. Cám ơn bạn nhiều nha.
Nhấp chuột vào đây để mở rộng...

file tổng hợp của bạn bao nhiêu dòng??
chắc giải pháp công thức lấy dữ liệu không hợp rồi

Sheet mới đó sẽ xóa, vì CT lỗi nên chưa xóa
 
Upvote 0
File tổng hợp mình khoảng tối đa là 10000 dòng.
Mình nghĩ có thể làm được vì nó chạy được trên excel 2010 mà. Vì file này chia sẻ cho rất nhiều anh chị lớn tuổi đã quen dùng excel 2003 nên mình mới muốn chạy trên excel 2003 thôi à.
winvista đã viết:
file tổng hợp của bạn bao nhiêu dòng??
chắc giải pháp công thức lấy dữ liệu không hợp rồi

Sheet mới đó sẽ xóa, vì CT lỗi nên chưa xóa
Nhấp chuột vào đây để mở rộng...
 
Upvote 0
phuocrobe đã viết:
File tổng hợp mình khoảng tối đa là 10000 dòng.
Mình nghĩ có thể làm được vì nó chạy được trên excel 2010 mà. Vì file này chia sẻ cho rất nhiều anh chị lớn tuổi đã quen dùng excel 2003 nên mình mới muốn chạy trên excel 2003 thôi à.
Nhấp chuột vào đây để mở rộng...

thế thì nhiều rồi, công thức mảng trong excel 2003 (có dùng trong thuật toán sub cũ) , không chịu được đâu

thử cái này xem có tải được không (đôi cách lấy dữ liệu, Phần tính toán giữ nguyên,)
PHP: 
Public Sub TDNH()
    
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
  
    Dim Res(), Arr(), i As Long, j As Long, k As Long, Filename As String, celIU As Range
    Dim Ws As Worksheet, Wb As Workbook
    
    On Error Resume Next
    Filename = ThisWorkbook.Path & "\TongHop.xls"
    Set Wb = Workbooks.Open(Filename, UpdateLinks:=False)
    If Wb Is Nothing Then
        Err.Clear
        MsgBox " khong ton tai file :" & vbCrLf & Filename
        GoTo LAEND
    End If
    On Error GoTo 0
    
    With Wb.Sheets("THA")
        Res = .Range("A10:EU" & .Range("A65500").End(xlUp).Row).Value
    End With
    
    Wb.Close False

    ReDim Preserve Arr(1 To UBound(Res), 1 To 12)
    For i = 1 To UBound(Res)
        If Res(i, 129) <> Empty Then
            k = k + 1
            Arr(k, 1) = k
            For j = 10 To 13
                Arr(k, j - 8) = Res(i, j)
            Next
            Arr(k, 6) = Res(i, 129)
            Arr(k, 7) = Res(i, 2)
            Arr(k, 8) = Res(i, 31)
            
            Arr(k, 9) = Res(i, 40) + Res(i, 49) + Res(i, 59) + Res(i, 66)
            Arr(k, 10) = Res(i, 91)
            Arr(k, 12) = Res(i, 130)
            If Res(i, 98) = 1 Then Arr(k, 11) = Range("Nguyen_nhan!B3").Value
            If Res(i, 99) = 1 Then Arr(k, 11) = Range("Nguyen_nhan!B4").Value
            If Res(i, 100) = 1 Then Arr(k, 11) = Range("Nguyen_nhan!B5").Value
            If Res(i, 101) = 1 Then Arr(k, 11) = Range("Nguyen_nhan!B6").Value
            If Res(i, 102) = 1 Then Arr(k, 11) = Range("Nguyen_nhan!B7").Value
            If Res(i, 103) = 1 Then Arr(k, 11) = Range("Nguyen_nhan!B8").Value
            If Res(i, 105) = 1 Then Arr(k, 11) = Range("Nguyen_nhan!B9").Value
            If Res(i, 89) = 1 Then Arr(k, 11) = Range("Nguyen_nhan!B10").Value
            If Res(i, 89) = 2 Then Arr(k, 11) = Range("Nguyen_nhan!B11").Value
            If Res(i, 106) = 1 Then Arr(k, 11) = Range("Nguyen_nhan!B12").Value
         End If
    Next
    If k Then Range("A10").Resize(k, 12).Value = Arr
LAEND:
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
End Sub
 
Lần chỉnh sửa cuối:
Upvote 0
Quá tuyệt vời bạn ơi, nhấn phát chạy ngay }}}}} Chân thành cám ơn bạn rất nhiều nhé }}}}}
winvista đã viết:
thế thì nhiều rồi, công thức mảng trong excel 2003 (có dùng trong thuật toán sub cũ) , không chịu được đâu

thử cái này xem có tải được không (đôi cách lấy dữ liệu, Phần tính toán giữ nguyên,)
PHP: 
Public Sub TDNH()
    
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
  
    Dim Res(), Arr(), i As Long, j As Long, k As Long, Filename As String, celIU As Range
    Dim Ws As Worksheet, Wb As Workbook
    
    On Error Resume Next
    Filename = ThisWorkbook.Path & "\TongHop.xls"
    Set Wb = Workbooks.Open(Filename, UpdateLinks:=False)
    If Wb Is Nothing Then
        Err.Clear
        MsgBox " khong ton tai file :" & vbCrLf & Filename
        GoTo LAEND
    End If
    On Error GoTo 0
    
    With Wb.Sheets("THA")
        Res = .Range("A10:EU" & .Range("A65500").End(xlUp).Row).Value
    End With
    
    Wb.Close False

    ReDim Preserve Arr(1 To UBound(Res), 1 To 12)
    For i = 1 To UBound(Res)
        If Res(i, 129) <> Empty Then
            k = k + 1
            Arr(k, 1) = k
            For j = 10 To 13
                Arr(k, j - 8) = Res(i, j)
            Next
            Arr(k, 6) = Res(i, 129)
            Arr(k, 7) = Res(i, 2)
            Arr(k, 8) = Res(i, 31)
            
            Arr(k, 9) = Res(i, 40) + Res(i, 49) + Res(i, 59) + Res(i, 66)
            Arr(k, 10) = Res(i, 91)
            Arr(k, 12) = Res(i, 130)
            If Res(i, 98) = 1 Then Arr(k, 11) = Range("Nguyen_nhan!B3").Value
            If Res(i, 99) = 1 Then Arr(k, 11) = Range("Nguyen_nhan!B4").Value
            If Res(i, 100) = 1 Then Arr(k, 11) = Range("Nguyen_nhan!B5").Value
            If Res(i, 101) = 1 Then Arr(k, 11) = Range("Nguyen_nhan!B6").Value
            If Res(i, 102) = 1 Then Arr(k, 11) = Range("Nguyen_nhan!B7").Value
            If Res(i, 103) = 1 Then Arr(k, 11) = Range("Nguyen_nhan!B8").Value
            If Res(i, 105) = 1 Then Arr(k, 11) = Range("Nguyen_nhan!B9").Value
            If Res(i, 89) = 1 Then Arr(k, 11) = Range("Nguyen_nhan!B10").Value
            If Res(i, 89) = 2 Then Arr(k, 11) = Range("Nguyen_nhan!B11").Value
            If Res(i, 106) = 1 Then Arr(k, 11) = Range("Nguyen_nhan!B12").Value
         End If
    Next
    If k Then Range("A10").Resize(k, 12).Value = Arr
LAEND:
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
End Sub
Nhấp chuột vào đây để mở rộng...
 
Upvote 0
Hix. Không phải rồi bạn ơi. Điều kiện để mình lấy dữ liệu ở cột DY bắt đầu từ dòng thứ 10 nếu ô nào có khác rỗng (có dữ liệu) thì mới bắt đầu lọc dữ liệu của dòng đó.
Code này những ô không có dữ liệu nó vẫn lấy thì không đúng theo điều kiện của mình rồi.
Và khi chạy code nó tự đóng file TongHop.xls mà mình đang mở nữa.

winvista đã viết:
thế thì nhiều rồi, công thức mảng trong excel 2003 (có dùng trong thuật toán sub cũ) , không chịu được đâu

thử cái này xem có tải được không (đôi cách lấy dữ liệu, Phần tính toán giữ nguyên,)
PHP: 
Public Sub TDNH()
    
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
  
    Dim Res(), Arr(), i As Long, j As Long, k As Long, Filename As String, celIU As Range
    Dim Ws As Worksheet, Wb As Workbook
    
    On Error Resume Next
    Filename = ThisWorkbook.Path & "\TongHop.xls"
    Set Wb = Workbooks.Open(Filename, UpdateLinks:=False)
    If Wb Is Nothing Then
        Err.Clear
        MsgBox " khong ton tai file :" & vbCrLf & Filename
        GoTo LAEND
    End If
    On Error GoTo 0
    
    With Wb.Sheets("THA")
        Res = .Range("A10:EU" & .Range("A65500").End(xlUp).Row).Value
    End With
    
    Wb.Close False

    ReDim Preserve Arr(1 To UBound(Res), 1 To 12)
    For i = 1 To UBound(Res)
        If Res(i, 129) <> Empty Then
            k = k + 1
            Arr(k, 1) = k
            For j = 10 To 13
                Arr(k, j - 8) = Res(i, j)
            Next
            Arr(k, 6) = Res(i, 129)
            Arr(k, 7) = Res(i, 2)
            Arr(k, 8) = Res(i, 31)
            
            Arr(k, 9) = Res(i, 40) + Res(i, 49) + Res(i, 59) + Res(i, 66)
            Arr(k, 10) = Res(i, 91)
            Arr(k, 12) = Res(i, 130)
            If Res(i, 98) = 1 Then Arr(k, 11) = Range("Nguyen_nhan!B3").Value
            If Res(i, 99) = 1 Then Arr(k, 11) = Range("Nguyen_nhan!B4").Value
            If Res(i, 100) = 1 Then Arr(k, 11) = Range("Nguyen_nhan!B5").Value
            If Res(i, 101) = 1 Then Arr(k, 11) = Range("Nguyen_nhan!B6").Value
            If Res(i, 102) = 1 Then Arr(k, 11) = Range("Nguyen_nhan!B7").Value
            If Res(i, 103) = 1 Then Arr(k, 11) = Range("Nguyen_nhan!B8").Value
            If Res(i, 105) = 1 Then Arr(k, 11) = Range("Nguyen_nhan!B9").Value
            If Res(i, 89) = 1 Then Arr(k, 11) = Range("Nguyen_nhan!B10").Value
            If Res(i, 89) = 2 Then Arr(k, 11) = Range("Nguyen_nhan!B11").Value
            If Res(i, 106) = 1 Then Arr(k, 11) = Range("Nguyen_nhan!B12").Value
         End If
    Next
    If k Then Range("A10").Resize(k, 12).Value = Arr
LAEND:
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
End Sub
Nhấp chuột vào đây để mở rộng...
 
Upvote 0
Nếu muốn nhanh, và chỉ có 1 nguyên nhân thôi (khi đã có 1 nguyên nhân, thi không cần xét tiếp,
và
Nhiều dòng thì sử dụng sub sau, đã xử lý cho tốc độ chỗ nguyên nhân (dùng ARRAY, và ElseIf)

PHP: 
Public Sub TDNH()
    
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
  
    Dim Res(), Arr(), i As Long, j As Long, k As Long, Filename As String, celIU As Range
    Dim Ws As Worksheet, Wb As Workbook
    
    On Error Resume Next
    Filename = ThisWorkbook.Path & "\TongHop.xls"
    Set Wb = Workbooks.Open(Filename, UpdateLinks:=False)
    If Wb Is Nothing Then
        Err.Clear
        MsgBox " khong ton tai file :" & vbCrLf & Filename
        GoTo LAEND
    End If
    On Error GoTo 0
    
    With Wb.Sheets("THA")
        Res = .Range("A10:EU" & .Range("A65500").End(xlUp).Row).Value
    End With
    
    Wb.Close False
    
    Dim aNguyenNhan
    aNguyenNhan = Range("Nguyen_nhan!B3").Resize(10).Value

    ReDim Preserve Arr(1 To UBound(Res), 1 To 12)
    For i = 1 To UBound(Res)
        If Res(i, 129) <> Empty Then
            k = k + 1
            Arr(k, 1) = k
            For j = 10 To 13
                Arr(k, j - 8) = Res(i, j)
            Next
            Arr(k, 6) = Res(i, 129)
            Arr(k, 7) = Res(i, 2)
            Arr(k, 8) = Res(i, 31)
            
            Arr(k, 9) = Res(i, 40) + Res(i, 49) + Res(i, 59) + Res(i, 66)
            Arr(k, 10) = Res(i, 91)
            Arr(k, 12) = Res(i, 130)
            
            If Res(i, 98) = 1 Then
                    Arr(k, 11) = aNguyenNhan(1, 1) ''Range("Nguyen_nhan!B3").Value
            ElseIf Res(i, 99) = 1 Then
                    Arr(k, 11) = aNguyenNhan(2, 1) ''Range("Nguyen_nhan!B4").Value
            ElseIf Res(i, 100) = 1 Then
                    Arr(k, 11) = aNguyenNhan(3, 1) ''Range("Nguyen_nhan!B5").Value
            ElseIf Res(i, 101) = 1 Then
                    Arr(k, 11) = aNguyenNhan(4, 1) ''Range("Nguyen_nhan!B6").Value
            ElseIf Res(i, 102) = 1 Then
                    Arr(k, 11) = aNguyenNhan(5, 1) ''Range("Nguyen_nhan!B7").Value
            ElseIf Res(i, 103) = 1 Then
                    Arr(k, 11) = aNguyenNhan(6, 1) ''Range("Nguyen_nhan!B8").Value
            ElseIf Res(i, 105) = 1 Then
                    Arr(k, 11) = aNguyenNhan(7, 1) ''Range("Nguyen_nhan!B9").Value
            ElseIf Res(i, 89) = 1 Then
                    Arr(k, 11) = aNguyenNhan(8, 1) ''Range("Nguyen_nhan!B10").Value
            ElseIf Res(i, 89) = 2 Then
                    Arr(k, 11) = aNguyenNhan(9, 1) ''Range("Nguyen_nhan!B11").Value
            ElseIf Res(i, 106) = 1 Then
                    Arr(k, 11) = aNguyenNhan(10, 1) ''Range("Nguyen_nhan!B12").Value
            End If
         End If
    Next
    If k Then Range("A10").Resize(k, 12).Value = Arr
LAEND:
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
End Sub
 
Upvote 0
phuocrobe đã viết:
Hix. Không phải rồi bạn ơi. Điều kiện để mình lấy dữ liệu ở cột DY bắt đầu từ dòng thứ 10 nếu ô nào có khác rỗng (có dữ liệu) thì mới bắt đầu lọc dữ liệu của dòng đó.
Code này những ô không có dữ liệu nó vẫn lấy thì không đúng theo điều kiện của mình rồi.
Và khi chạy code nó tự đóng file TongHop.xls mà mình đang mở nữa.
Nhấp chuột vào đây để mở rộng...

DY của file nào, sheet nào?

phần tính toán giữ nguyên code của bạn mà?

Tôi chạy ở ex2010 vẫn đúng kết quả,

bạn thử đổi dòng này
If Res(i, 129) <> Empty Then
thành 1 trong các cách sau:

If Res(i, 129) <> "" Then

hoặc

If Res(i, 129) <> 0 Then

hoặc

If Len(Res(i, 129)) > 0 Then

thêm có khả thi không, có thể excel 2003 nó khác
 
Lần chỉnh sửa cuối:
Upvote 0
sửa lại lần cuối, nếu tonghop đang mở, thì không đóng lại (còn đang đóng, thì sẽ mở xong đóng lại trả như cũ),
tự kiểm tra kết quả

thay mới hơn
PHP: 
Public Sub TDNH()
    
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    
    Const tenFILE = "TongHop.xls"
  
    Dim Res(), Arr(), i As Long, j As Long, k As Long, Filename As String
    Dim Ws As Worksheet, Wb As Workbook, OKmo As Boolean
    
    On Error Resume Next
    Filename = ThisWorkbook.Path & "\" & tenFILE '" lua chon
    
    Set Wb = Workbooks(tenFILE)
    If Wb Is Nothing Then
        OKmo = False
        Err.Clear
        Set Wb = Workbooks.Open(Filename, UpdateLinks:=False)
        If Wb Is Nothing Then
            Err.Clear
            MsgBox " khong ton tai file :" & vbCrLf & Filename
            GoTo LAEND
        End If
    Else
        OKmo = True
    End If
    On Error GoTo 0
    
    With Wb.Sheets("THA")
        Res = .Range("A10:EU" & .Range("A65500").End(xlUp).Row).Value
    End With
    
    If Not OKmo Then Wb.Close False
    
    Dim aNguyenNhan, jj, vl
    aNguyenNhan = ThisWorkbook.Sheets("Nguyen_nhan").Range("B3").Resize(10).Value
    
    jj = Array(98, 99, 100, 101, 102, 103, 105, 89, 89, 106) ''=1
    vl = Array(1, 1, 1, 1, 1, 1, 1, 1, 2, 1)

    ReDim Preserve Arr(1 To UBound(Res), 1 To 12)
    For i = 1 To UBound(Res)
        If Res(i, 129) <> "" Then
            k = k + 1
            Arr(k, 1) = k
            For j = 10 To 13
                Arr(k, j - 8) = Res(i, j)
            Next
            
            Arr(k, 6) = Res(i, 129)
            Arr(k, 7) = Res(i, 2)
            Arr(k, 8) = Res(i, 31)
            Arr(k, 9) = Res(i, 40) + Res(i, 49) + Res(i, 59) + Res(i, 66)
            Arr(k, 10) = Res(i, 91)
            Arr(k, 12) = Res(i, 130)
            
            For j = 0 To 9
                If Res(i, jj(j)) = vl(j) Then Arr(k, 11) = aNguyenNhan(j + 1, 1): Exit For
            Next j
          
         End If
    Next
    If k > 0 Then Range("A10").Resize(k, 12).Value = Arr
LAEND:
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
End Sub
 
Lần chỉnh sửa cuối:
Upvote 0
Code chạy ok lắm anh, đã ra kết quả nhưng còn 1 vấn đề nữa là nó không xóa các dòng dữ liệu cũ trước khi cập nhật dữ liệu vào file 04.xls vì nếu ban đầu nó cho ra kết quả là 10 dòng nhưng số liệu này thường xuyên thay đổi, có lúc kết quả chỉ có 3 dòng thì còn 7 dòng khi chạy code trước đó nó vẫn còn mà chưa xóa đi.
Anh giúp nốt em phần này nữa thì hoàn chỉnh rồi đấy ạ. Cám ơn anh rất rất nhiều ạ )(&&@@
winvista đã viết:
sửa lại lần cuối, nếu tonghop đang mở, thì không đóng lại (còn đang đóng, thì sẽ mở xong đóng lại trả như cũ),
tự kiểm tra kết quả

thay mới hơn
PHP: 
Public Sub TDNH()
    
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    
    Const tenFILE = "TongHop.xls"
  
    Dim Res(), Arr(), i As Long, j As Long, k As Long, Filename As String
    Dim Ws As Worksheet, Wb As Workbook, OKmo As Boolean
    
    On Error Resume Next
    Filename = ThisWorkbook.Path & "\" & tenFILE '" lua chon
    
    Set Wb = Workbooks(tenFILE)
    If Wb Is Nothing Then
        OKmo = False
        Err.Clear
        Set Wb = Workbooks.Open(Filename, UpdateLinks:=False)
        If Wb Is Nothing Then
            Err.Clear
            MsgBox " khong ton tai file :" & vbCrLf & Filename
            GoTo LAEND
        End If
    Else
        OKmo = True
    End If
    On Error GoTo 0
    
    With Wb.Sheets("THA")
        Res = .Range("A10:EU" & .Range("A65500").End(xlUp).Row).Value
    End With
    
    If Not OKmo Then Wb.Close False
    
    Dim aNguyenNhan, jj, vl
    aNguyenNhan = ThisWorkbook.Sheets("Nguyen_nhan").Range("B3").Resize(10).Value
    
    jj = Array(98, 99, 100, 101, 102, 103, 105, 89, 89, 106) ''=1
    vl = Array(1, 1, 1, 1, 1, 1, 1, 1, 2, 1)

    ReDim Preserve Arr(1 To UBound(Res), 1 To 12)
    For i = 1 To UBound(Res)
        If Res(i, 129) <> "" Then
            k = k + 1
            Arr(k, 1) = k
            For j = 10 To 13
                Arr(k, j - 8) = Res(i, j)
            Next
            
            Arr(k, 6) = Res(i, 129)
            Arr(k, 7) = Res(i, 2)
            Arr(k, 8) = Res(i, 31)
            Arr(k, 9) = Res(i, 40) + Res(i, 49) + Res(i, 59) + Res(i, 66)
            Arr(k, 10) = Res(i, 91)
            Arr(k, 12) = Res(i, 130)
            
            For j = 0 To 9
                If Res(i, jj(j)) = vl(j) Then Arr(k, 11) = aNguyenNhan(j + 1, 1): Exit For
            Next j
          
         End If
    Next
    If k > 0 Then Range("A10").Resize(k, 12).Value = Arr
LAEND:
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
End Sub
Nhấp chuột vào đây để mở rộng...
 
Upvote 0
thêm dòng này
Range([A10],Range("A65500").End(xlUp)).Resize(,12).ClearContents

trước dòng (thứ 5 từ cuối chương trình lên)
If k > 0 Then Range("A10").Resize(k, 12).Value = Arr

là được

lưu ý tôi mới thêm dấu "," trước số 12
 
Lần chỉnh sửa cuối:
Upvote 0
Quá tuyệt vời anh ạ, như vậy là đã hoàn chỉnh ròi ạ, cám ơn anh rất nhiều anh ạ, chúc anh luôn vui vẻ hạnh phúc nhé -=.,,
winvista đã viết:
thêm dòng này
Range([A10],Range("A65500").End(xlUp)).Resize(,12).ClearContents

trước dòng (thứ 5 từ cuối chương trình lên)
If k > 0 Then Range("A10").Resize(k, 12).Value = Arr

là được

lưu ý tôi mới thêm dấu "," trước số 12
Nhấp chuột vào đây để mở rộng...
 
Upvote 0
Em còn 1 việc này nữa, em có đăng ở bài khác mà chưa ai giúp được hết, tiện thể anh giúp em luôn nha. Cám ơn anh !
http://www.giaiphapexcel.com/forum/...ộng-trừ-khi-chạy-code-VBA&p=770116#post770116
winvista đã viết:
thêm dòng này
Range([A10],Range("A65500").End(xlUp)).Resize(,12).ClearContents

trước dòng (thứ 5 từ cuối chương trình lên)
If k > 0 Then Range("A10").Resize(k, 12).Value = Arr

là được

lưu ý tôi mới thêm dấu "," trước số 12
Nhấp chuột vào đây để mở rộng...
 
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

B
Làm sao đổi đơn vị B, M này sang hàng đơn vị vậy mọi người?
    • Cười
Trả lời
1
Đọc
11
ptm0412
ptm0412
N
Thử lập trình XLL add-in bằng C/C++
Trả lời
0
Đọc
8
nguyendang95
N
Tuấn Bụng Bự
tạo QRcode chuyển khoản ngân hàng
Trả lời
5
Đọc
178
Tuấn Bụng Bự
Tuấn Bụng Bự
V
Làm mẫu giấy đi đường (công lệnh) bằng Excel
Trả lời
11
Đọc
11K
dungnguyenMNCK
D
M
Tự chèn dòng khi cập nhật dữ liệu từ trang tính khác.
Trả lời
1
Đọc
29
BuiQuangThuan
B
TrungChinhs
  • Question Question
Hỏi cách làm tròn số trong VBA
Trả lời
7
Đọc
7K
ptm0412
ptm0412
SA_DQ
[Xin hỏi] Cách tính số tiền bình quân của tài khoản trong 1 tháng
Trả lời
7
Đọc
104
ptm0412
ptm0412
Quách Ngọc
Trả về kết quả ngày tháng hay khoảng trống
Trả lời
3
Đọc
51
Quách Ngọc
Quách Ngọc
MaxanB
Cần hỗ trợ công thức Vlookup nhiều sheet theo điều kiên
Trả lời
2
Đọc
65
MaxanB
MaxanB
N
Không chạy được file VBA
Trả lời
3
Đọc
133
nhjngj
N
N
Xin giúp e cách lọc dữ liệu bị trùng
Trả lời
1
Đọc
53
hoangtuaotrang_hp_vn
H
tonny jj
Lập hàm thể hiện số công lệnh của ngày đi công tác
Trả lời
8
Đọc
225
Nguyễn Nal
N
H
chuyển dữ liệu từ 1 dòng thành nhiều dòng,
Trả lời
13
Đọc
143
Duy Tùng 9x
Duy Tùng 9x
K
Hỏi lỗi không kéo được công thức (Ctrl+D)
Trả lời
7
Đọc
120
khoinguyen2024
K
C
Filter có điều kiện đang ở dạng Cột
Trả lời
3
Đọc
112
Chí Còn Phí
C
H
Quản Lý Công Văn đi Và đến
9 10 11
Trả lời
216
Đọc
159K
dungnguyenMNCK
D
Nguyễn Duy Tuân
Hướng dẫn lập trình với Google Sheets và Excel Online bằng Excel VBA và Add-in A-Tools v10
    • Thích
Trả lời
10
Đọc
574
Nguyễn Duy Tuân
Nguyễn Duy Tuân
dongbhhg
Tìm lương cơ sở theo từng tháng
Trả lời
2
Đọc
60
Duy Tùng 9x
Duy Tùng 9x
Vũ Thị Thuý Ly
Em xin nhờ các anh chị trên diễn đàn giúp đỡ viết hàm hoặc VBA tính tổng các giá trị theo điều kiện
Trả lời
3
Đọc
50
bebo021999
B
DinhManh1307
Cách thống kê công việc sản xuất từng người để tính lương sản phẩm
Trả lời
16
Đọc
268
DinhManh1307
DinhManh1307
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
TALKSHOW KHÁM PHÁ SỨC MẠNH HÀM FILTER TRONG EXCEL 365
Back
Top Bottom