Màn hình bị giật khi chạy macro

Liên hệ QC
JungSangAh

JungSangAh

Thành viên mới
Tham gia
2/6/18
Bài viết
43
Được thích
14
Xin chào các anh chị ạ.
Em có một file excel kèm theo rất mong được các anh chị giúp đỡ ạ.
1/ Khi em chạy macro "lưu" ở sheet "nhap_lieu", màn hình bị giật liên tục ạ. Các anh chị có thể khắc phục giúp em được ko ạ?
2/ Các anh chị có thể giúp em viết code để trích xuất dữ liệu từ sheet "nhap_lieu" sang sheet "CTGNM" theo các điều kiện ở sheet CTGNM được ko ạ?
Do em mò mẫm làm VBA nên các câu lệnh chủ yếu bằng record macro nên chạy rất chậm và cứ chồng chéo nhau thôi ạ. Nếu anh chị nào có thời gian có thể kiện toàn code giúp em với ạ.
Em xin chân thành cảm ơn mọi sự giúp đỡ của cả nhà ạ.
Chúc cả nhà GPE cuối tuần vui vẻ ạ.
 

File đính kèm

  • PMKH_2.xlsm
    1.8 MB · Đọc: 21
JungSangAh đã viết:
Xin chào các anh chị ạ.
Em có một file excel kèm theo rất mong được các anh chị giúp đỡ ạ.
1/ Khi em chạy macro "lưu" ở sheet "nhap_lieu", màn hình bị giật liên tục ạ. Các anh chị có thể khắc phục giúp em được ko ạ?
2/ Các anh chị có thể giúp em viết code để trích xuất dữ liệu từ sheet "nhap_lieu" sang sheet "CTGNM" theo các điều kiện ở sheet CTGNM được ko ạ?
Do em mò mẫm làm VBA nên các câu lệnh chủ yếu bằng record macro nên chạy rất chậm và cứ chồng chéo nhau thôi ạ. Nếu anh chị nào có thời gian có thể kiện toàn code giúp em với ạ.
Em xin chân thành cảm ơn mọi sự giúp đỡ của cả nhà ạ.
Chúc cả nhà GPE cuối tuần vui vẻ ạ.
Nhấp chuột vào đây để mở rộng...
File bạn chậm do.
1. Quá nhiều dữ liệu.
2. Quá nhiều định dạng.
3. Quá nhiều công thức.
4. Code của bạn chủ yếu là Record Macro, nên thao tác hầu như là trực tiếp đến ô trong sheet nên tốc độ xử lý sẽ chậm là đương nhiên.
Cách khắc phục có thể gợi ý cho bạn như sau:
1. Không nên tô màu cho những vùng không sử dụng tới, ví dụ có những sheet dùng ít dữ liệu nhưng bạn lại tô màu nền hết cả sheet.
2. Hạn chế dùng hình ảnh trong sheet.
3. Những chổ dùng công thức nếu được thì chuyển sang dùng code luôn cho nhẹ.
4. Những chổ chưa dùng thì bỏ hẳn công thức đi cho nhẹ tính toán.
5. Thay các thao tác tính toán trực tiếp trên ô ra tính toán trên mảng sau đó gán ngược vào ô.
Tôi chỉ góp vài ý vậy còn giúp thì thua, chỉ góp lời chứ không góp vốn. Thấy file của bạn một mâm code thế kia dò và sửa từng đoạn chắc chết.
 
giaiphap đã viết:
File bạn chậm do.
1. Quá nhiều dữ liệu.
2. Quá nhiều định dạng.
3. Quá nhiều công thức.
4. Code của bạn chủ yếu là Record Macro, nên thao tác hầu như là trực tiếp đến ô trong sheet nên tốc độ xử lý sẽ chậm là đương nhiên.
Cách khắc phục có thể gợi ý cho bạn như sau:
1. Không nên tô màu cho những vùng không sử dụng tới, ví dụ có những sheet dùng ít dữ liệu nhưng bạn lại tô màu nền hết cả sheet.
2. Hạn chế dùng hình ảnh trong sheet.
3. Những chổ dùng công thức nếu được thì chuyển sang dùng code luôn cho nhẹ.
4. Những chổ chưa dùng thì bỏ hẳn công thức đi cho nhẹ tính toán.
5. Thay các thao tác tính toán trực tiếp trên ô ra tính toán trên mảng sau đó gán ngược vào ô.
Tôi chỉ góp vài ý vậy còn giúp thì thua, chỉ góp lời chứ không góp vốn. Thấy file của bạn một mâm code thế kia dò và sửa từng đoạn chắc chết.
Nhấp chuột vào đây để mở rộng...
Bài đã được tự động gộp:

Dạ, em cảm ơn góp ý của anh ạ. Em chưa hiểu mục "5. Thay các thao tác tính toán trực tiếp trên ô ra tính toán trên mảng sau đó gán ngược vào ô ". Anh có thể ví dụ giúp em ko ạ?
 
JungSangAh đã viết:
Xin chào các anh chị ạ.
Em có một file excel kèm theo rất mong được các anh chị giúp đỡ ạ.
1/ Khi em chạy macro "lưu" ở sheet "nhap_lieu", màn hình bị giật liên tục ạ. Các anh chị có thể khắc phục giúp em được ko ạ?
2/ Các anh chị có thể giúp em viết code để trích xuất dữ liệu từ sheet "nhap_lieu" sang sheet "CTGNM" theo các điều kiện ở sheet CTGNM được ko ạ?
Do em mò mẫm làm VBA nên các câu lệnh chủ yếu bằng record macro nên chạy rất chậm và cứ chồng chéo nhau thôi ạ. Nếu anh chị nào có thời gian có thể kiện toàn code giúp em với ạ.
Em xin chân thành cảm ơn mọi sự giúp đỡ của cả nhà ạ.
Chúc cả nhà GPE cuối tuần vui vẻ ạ.
Nhấp chuột vào đây để mở rộng...
Một số ý kiến
1/ Màn hình bị giật liên tục vì bạn đang thiết lập sự kiện Worksheet_Change, trong khi code Lưu lại có nhiều lần active các ô trong sheet "nhaplieu"
Để khắc phục tôi có sửa lại code của bạn như sau:
PHP: 
Sub Lenh_luu_nhaplieu_dasua()
    Dim SourceData As Variant, DVGM(), DVNM(), GetData(1 To 1, 1 To 16)
    Dim lR As Long, I As Long
    
    Application.ScreenUpdating = False
    lR = Sheet82.Range("B" & Rows.Count).End(xlUp).Row + 1 'Dong cuoi cot B
    DVGM = Sheet23.Range("B10", Sheet23.Range("B10").End(xlDown)).Resize(, 2).Value
    DVNM = Sheet83.Range("B10", Sheet83.Range("B10").End(xlDown)).Resize(, 2).Value
    SourceData = Array("C1", "C2", "", "C3", "C4", "C5", "C6", "E2", "", "E3", "E4", "E5", "E6", "E1", "C7")
    
    'Dien so thu tu
    If lR = 9 Then
        GetData(1, 1) = 1
    Else
        GetData(1, 1) = Sheet82.Range("A" & lR).Offset(-1).Value + 1
    End If
    
    'Lay cac thong tin tu cac o C1, C2,... vao mang ket qua
    For I = LBound(SourceData) To UBound(SourceData)
        If Len(SourceData(I)) Then GetData(1, I + 2) = Sheet82.Range(SourceData(I))
    Next I
    
    'Lay thong tin don vi gui mau
    For I = 1 To UBound(DVGM, 1)
        If GetData(1, 3) = DVGM(I, 1) Then
            GetData(1, 4) = DVGM(I, 2)
            Exit For
        End If
    Next I
    
    'Lay thong tin don vi nhan mau
    For I = 1 To UBound(DVNM, 1)
        If GetData(1, 9) = DVNM(I, 1) Then
            GetData(1, 10) = DVNM(I, 2)
            Exit For
        End If
    Next I
    
    'Gan mang ket qua vao dong cuoi
    Sheet82.Range("A" & lR).Resize(, 16) = GetData
    
    'Lay thong tin So phieu GM/PT
    Sheet82.Range("P" & lR) = Left(Sheet82.Range("C" & lR), InStr(Sheet82.Range("C" & lR), "/")) & _
                                ".T" & Month(Sheet82.Range("B" & lR)) & "/" & _
                                Format(Application.WorksheetFunction.CountIf(Sheet82.Range("C9:C" & lR), _
                                Left(Sheet82.Range("C" & lR), InStr(Sheet82.Range("C" & lR), "/")) & "*"), "000")
    Application.ScreenUpdating = True
    
    MsgBox "Da luu du lieu", vbInformation, "GPE"
End Sub
Tiện viết lại luôn code cho sự kiện Worksheet_Change cho gọn
PHP: 
Sub Lenh_lay_ND_nhaplieu_dasua()
    Dim a As Long, SourceData, Data()
    
    SourceData = Array("C1", "C2", "", "C3", "C4", "C5", "C6", "E2", "", "E3", "E4", "E5", "E6", "E1", "C7")
    a = ActiveCell.Row
    
    Application.ScreenUpdating = False
    With Sheet82
        'Tao mang luu du lieu dong du lieu active
        Data() = .Range("A" & a).Resize(, 16)
        'Lay cac thong tin tu Data() vao cac o C1, C2,...
        For I = LBound(SourceData) To UBound(SourceData)
            If Len(SourceData(I)) Then .Range(SourceData(I)) = Data(1, I + 2)
        Next I
        .Range("A1").Value = a
    End With
    Application.ScreenUpdating = True
End Sub
2/ Đối với Sổ chi tiết giao nhận mẫu, tôi thấy có vấn đề sau:
- Ô C7 là Mã ĐVGM/NM nhưng C8 chỉ có ĐVGM
- Ở Sheet "nhaplieu" có 3 cột Số lượng nhưng không biết bạn cần lọc cột nào.
- Tôi đã viết code lọc cho bạn với điều kiện lấy số liệu cột Số lượng mẫu CB
PHP: 
Sub SochitietGNM()
    Dim Nhaplieu(), Ketqua()
    Dim I As Long, J As Long, K As Long
    
    Nhaplieu = Sheet82.Range("B9", Sheet82.Range("B9").End(xlDown)).Resize(, 15).Value
    ReDim Ketqua(1 To UBound(Nhaplieu, 1), 1 To 6)
    
    For I = 1 To UBound(Nhaplieu, 1)
        If Nhaplieu(I, 1) >= Sheet17.Range("D4") And Nhaplieu(I, 1) <= Sheet17.Range("D5") Then
            If Nhaplieu(I, 2) = Sheet17.Range("C8") Then
                K = K + 1: Ketqua(K, 1) = K
                Ketqua(K, 2) = Nhaplieu(I, 15): Ketqua(K, 3) = Nhaplieu(I, 4)
                Ketqua(K, 4) = Nhaplieu(I, 11): Ketqua(K, 5) = Nhaplieu(I, 6)
                Ketqua(K, 6) = Nhaplieu(I, 7)
            End If
        End If
    Next I
    
    Sheet17.Range("B11:G23").ClearContents
    If K Then
        Sheet17.Range("B11").Resize(K, 6) = Ketqua
        MsgBox "Done", vbInformation, "GPE"
    Else
        MsgBox "Khong co du lieu thoa man", vbCritical, "GPE"
    End If
End Sub
 
vanthinh3101 đã viết:
Một số ý kiến
1/ Màn hình bị giật liên tục vì bạn đang thiết lập sự kiện Worksheet_Change, trong khi code Lưu lại có nhiều lần active các ô trong sheet "nhaplieu"
Để khắc phục tôi có sửa lại code của bạn như sau:
PHP: 
Sub Lenh_luu_nhaplieu_dasua()
    Dim SourceData As Variant, DVGM(), DVNM(), GetData(1 To 1, 1 To 16)
    Dim lR As Long, I As Long
   
    Application.ScreenUpdating = False
    lR = Sheet82.Range("B" & Rows.Count).End(xlUp).Row + 1 'Dong cuoi cot B
    DVGM = Sheet23.Range("B10", Sheet23.Range("B10").End(xlDown)).Resize(, 2).Value
    DVNM = Sheet83.Range("B10", Sheet83.Range("B10").End(xlDown)).Resize(, 2).Value
    SourceData = Array("C1", "C2", "", "C3", "C4", "C5", "C6", "E2", "", "E3", "E4", "E5", "E6", "E1", "C7")
   
    'Dien so thu tu
    If lR = 9 Then
        GetData(1, 1) = 1
    Else
        GetData(1, 1) = Sheet82.Range("A" & lR).Offset(-1).Value + 1
    End If
   
    'Lay cac thong tin tu cac o C1, C2,... vao mang ket qua
    For I = LBound(SourceData) To UBound(SourceData)
        If Len(SourceData(I)) Then GetData(1, I + 2) = Sheet82.Range(SourceData(I))
    Next I
   
    'Lay thong tin don vi gui mau
    For I = 1 To UBound(DVGM, 1)
        If GetData(1, 3) = DVGM(I, 1) Then
            GetData(1, 4) = DVGM(I, 2)
            Exit For
        End If
    Next I
   
    'Lay thong tin don vi nhan mau
    For I = 1 To UBound(DVNM, 1)
        If GetData(1, 9) = DVNM(I, 1) Then
            GetData(1, 10) = DVNM(I, 2)
            Exit For
        End If
    Next I
   
    'Gan mang ket qua vao dong cuoi
    Sheet82.Range("A" & lR).Resize(, 16) = GetData
   
    'Lay thong tin So phieu GM/PT
    Sheet82.Range("P" & lR) = Left(Sheet82.Range("C" & lR), InStr(Sheet82.Range("C" & lR), "/")) & _
                                ".T" & Month(Sheet82.Range("B" & lR)) & "/" & _
                                Format(Application.WorksheetFunction.CountIf(Sheet82.Range("C9:C" & lR), _
                                Left(Sheet82.Range("C" & lR), InStr(Sheet82.Range("C" & lR), "/")) & "*"), "000")
    Application.ScreenUpdating = True
   
    MsgBox "Da luu du lieu", vbInformation, "GPE"
End Sub
Tiện viết lại luôn code cho sự kiện Worksheet_Change cho gọn
PHP: 
Sub Lenh_lay_ND_nhaplieu_dasua()
    Dim a As Long, SourceData, Data()
   
    SourceData = Array("C1", "C2", "", "C3", "C4", "C5", "C6", "E2", "", "E3", "E4", "E5", "E6", "E1", "C7")
    a = ActiveCell.Row
   
    Application.ScreenUpdating = False
    With Sheet82
        'Tao mang luu du lieu dong du lieu active
        Data() = .Range("A" & a).Resize(, 16)
        'Lay cac thong tin tu Data() vao cac o C1, C2,...
        For I = LBound(SourceData) To UBound(SourceData)
            If Len(SourceData(I)) Then .Range(SourceData(I)) = Data(1, I + 2)
        Next I
        .Range("A1").Value = a
    End With
    Application.ScreenUpdating = True
End Sub
2/ Đối với Sổ chi tiết giao nhận mẫu, tôi thấy có vấn đề sau:
- Ô C7 là Mã ĐVGM/NM nhưng C8 chỉ có ĐVGM
- Ở Sheet "nhaplieu" có 3 cột Số lượng nhưng không biết bạn cần lọc cột nào.
- Tôi đã viết code lọc cho bạn với điều kiện lấy số liệu cột Số lượng mẫu CB
PHP: 
Sub SochitietGNM()
    Dim Nhaplieu(), Ketqua()
    Dim I As Long, J As Long, K As Long
   
    Nhaplieu = Sheet82.Range("B9", Sheet82.Range("B9").End(xlDown)).Resize(, 15).Value
    ReDim Ketqua(1 To UBound(Nhaplieu, 1), 1 To 6)
   
    For I = 1 To UBound(Nhaplieu, 1)
        If Nhaplieu(I, 1) >= Sheet17.Range("D4") And Nhaplieu(I, 1) <= Sheet17.Range("D5") Then
            If Nhaplieu(I, 2) = Sheet17.Range("C8") Then
                K = K + 1: Ketqua(K, 1) = K
                Ketqua(K, 2) = Nhaplieu(I, 15): Ketqua(K, 3) = Nhaplieu(I, 4)
                Ketqua(K, 4) = Nhaplieu(I, 11): Ketqua(K, 5) = Nhaplieu(I, 6)
                Ketqua(K, 6) = Nhaplieu(I, 7)
            End If
        End If
    Next I
   
    Sheet17.Range("B11:G23").ClearContents
    If K Then
        Sheet17.Range("B11").Resize(K, 6) = Ketqua
        MsgBox "Done", vbInformation, "GPE"
    Else
        MsgBox "Khong co du lieu thoa man", vbCritical, "GPE"
    End If
End Sub
Nhấp chuột vào đây để mở rộng...

Em cảm ơn anh ạ. Anh có thể cho em xin file sau khi a sửa lại code được ko ạ? vì em copy đoạn code này vào sổ CT thì nó ko có cột số lượng và số phiếu anh ạ.. và vì sao sau khi chạy code thì định dạng của nó thay đổi vậy anh?
 
JungSangAh đã viết:
Em cảm ơn anh ạ. Anh có thể cho em xin file sau khi a sửa lại code được ko ạ? vì em copy đoạn code này vào sổ CT thì nó ko có cột số lượng và số phiếu anh ạ.. và vì sao sau khi chạy code thì định dạng của nó thay đổi vậy anh?
Nhấp chuột vào đây để mở rộng...
Gửi bạn.
2 code sửa lại ở phần cuối cùng của Module NHAPLIEU
Code để lọc dữ liệu thì ở Module3
 

File đính kèm

  • PMKH_2.xlsm
    1.8 MB · Đọc: 16
vanthinh3101 đã viết:
Một số ý kiến
1/ Màn hình bị giật liên tục vì bạn đang thiết lập sự kiện Worksheet_Change, trong khi code Lưu lại có nhiều lần active các ô trong sheet "nhaplieu"
Để khắc phục tôi có sửa lại code của bạn như sau:
PHP: 
Sub Lenh_luu_nhaplieu_dasua()
    Dim SourceData As Variant, DVGM(), DVNM(), GetData(1 To 1, 1 To 16)
    Dim lR As Long, I As Long
   
    Application.ScreenUpdating = False
    lR = Sheet82.Range("B" & Rows.Count).End(xlUp).Row + 1 'Dong cuoi cot B
    DVGM = Sheet23.Range("B10", Sheet23.Range("B10").End(xlDown)).Resize(, 2).Value
    DVNM = Sheet83.Range("B10", Sheet83.Range("B10").End(xlDown)).Resize(, 2).Value
    SourceData = Array("C1", "C2", "", "C3", "C4", "C5", "C6", "E2", "", "E3", "E4", "E5", "E6", "E1", "C7")
   
    'Dien so thu tu
    If lR = 9 Then
        GetData(1, 1) = 1
    Else
        GetData(1, 1) = Sheet82.Range("A" & lR).Offset(-1).Value + 1
    End If
   
    'Lay cac thong tin tu cac o C1, C2,... vao mang ket qua
    For I = LBound(SourceData) To UBound(SourceData)
        If Len(SourceData(I)) Then GetData(1, I + 2) = Sheet82.Range(SourceData(I))
    Next I
   
    'Lay thong tin don vi gui mau
    For I = 1 To UBound(DVGM, 1)
        If GetData(1, 3) = DVGM(I, 1) Then
            GetData(1, 4) = DVGM(I, 2)
            Exit For
        End If
    Next I
   
    'Lay thong tin don vi nhan mau
    For I = 1 To UBound(DVNM, 1)
        If GetData(1, 9) = DVNM(I, 1) Then
            GetData(1, 10) = DVNM(I, 2)
            Exit For
        End If
    Next I
   
    'Gan mang ket qua vao dong cuoi
    Sheet82.Range("A" & lR).Resize(, 16) = GetData
   
    'Lay thong tin So phieu GM/PT
    Sheet82.Range("P" & lR) = Left(Sheet82.Range("C" & lR), InStr(Sheet82.Range("C" & lR), "/")) & _
                                ".T" & Month(Sheet82.Range("B" & lR)) & "/" & _
                                Format(Application.WorksheetFunction.CountIf(Sheet82.Range("C9:C" & lR), _
                                Left(Sheet82.Range("C" & lR), InStr(Sheet82.Range("C" & lR), "/")) & "*"), "000")
    Application.ScreenUpdating = True
   
    MsgBox "Da luu du lieu", vbInformation, "GPE"
End Sub
Tiện viết lại luôn code cho sự kiện Worksheet_Change cho gọn
PHP: 
Sub Lenh_lay_ND_nhaplieu_dasua()
    Dim a As Long, SourceData, Data()
   
    SourceData = Array("C1", "C2", "", "C3", "C4", "C5", "C6", "E2", "", "E3", "E4", "E5", "E6", "E1", "C7")
    a = ActiveCell.Row
   
    Application.ScreenUpdating = False
    With Sheet82
        'Tao mang luu du lieu dong du lieu active
        Data() = .Range("A" & a).Resize(, 16)
        'Lay cac thong tin tu Data() vao cac o C1, C2,...
        For I = LBound(SourceData) To UBound(SourceData)
            If Len(SourceData(I)) Then .Range(SourceData(I)) = Data(1, I + 2)
        Next I
        .Range("A1").Value = a
    End With
    Application.ScreenUpdating = True
End Sub
2/ Đối với Sổ chi tiết giao nhận mẫu, tôi thấy có vấn đề sau:
- Ô C7 là Mã ĐVGM/NM nhưng C8 chỉ có ĐVGM
- Ở Sheet "nhaplieu" có 3 cột Số lượng nhưng không biết bạn cần lọc cột nào.
- Tôi đã viết code lọc cho bạn với điều kiện lấy số liệu cột Số lượng mẫu CB
PHP: 
Sub SochitietGNM()
    Dim Nhaplieu(), Ketqua()
    Dim I As Long, J As Long, K As Long
   
    Nhaplieu = Sheet82.Range("B9", Sheet82.Range("B9").End(xlDown)).Resize(, 15).Value
    ReDim Ketqua(1 To UBound(Nhaplieu, 1), 1 To 6)
   
    For I = 1 To UBound(Nhaplieu, 1)
        If Nhaplieu(I, 1) >= Sheet17.Range("D4") And Nhaplieu(I, 1) <= Sheet17.Range("D5") Then
            If Nhaplieu(I, 2) = Sheet17.Range("C8") Then
                K = K + 1: Ketqua(K, 1) = K
                Ketqua(K, 2) = Nhaplieu(I, 15): Ketqua(K, 3) = Nhaplieu(I, 4)
                Ketqua(K, 4) = Nhaplieu(I, 11): Ketqua(K, 5) = Nhaplieu(I, 6)
                Ketqua(K, 6) = Nhaplieu(I, 7)
            End If
        End If
    Next I
   
    Sheet17.Range("B11:G23").ClearContents
    If K Then
        Sheet17.Range("B11").Resize(K, 6) = Ketqua
        MsgBox "Done", vbInformation, "GPE"
    Else
        MsgBox "Khong co du lieu thoa man", vbCritical, "GPE"
    End If
End Sub
Nhấp chuột vào đây để mở rộng...
Anh ơi. Nếu anh không phiền anh có giải thích giúp em code này được ko ạ. Em muốn hiểu nó để áp dụng cho các sheet khác nữa ạ. EM chân thành cảm ơn anh
 
JungSangAh đã viết:
Anh ơi. Nếu anh không phiền anh có giải thích giúp em code này được ko ạ. Em muốn hiểu nó để áp dụng cho các sheet khác nữa ạ. EM chân thành cảm ơn anh
Nhấp chuột vào đây để mở rộng...
Tôi viết 3 code, code nào bạn cần giải thích.
Tôi có viết chỉ dẫn ở code đầu tiên của bài #4 rồi, code thứ 2 thì tương tự code đầu tiên nhưng cách lấy dữ liệu ngược lại.
Code thứ 3:
PHP: 
Sub SochitietGNM()
    Dim Nhaplieu(), Ketqua()
    Dim I As Long, J As Long, K As Long
    
    'Tao mang chua du lieu tu cot B den cot P trong Sheets("nhap_lieu")
    Nhaplieu = Sheet82.Range("B9", Sheet82.Range("B9").End(xlDown)).Resize(, 15).Value
    'Khai bao kich thuoc mang ket qua
    ReDim Ketqua(1 To UBound(Nhaplieu, 1), 1 To 6)
    
    For I = 1 To UBound(Nhaplieu, 1)
        'Kiem tra gia tri cot B trong Sheets("nhap_lieu") co nam trong khoang thoi gian can loc hay khong?
        If Nhaplieu(I, 1) >= Sheet17.Range("D4") And Nhaplieu(I, 1) <= Sheet17.Range("D5") Then
            'Kiem tra gia tri cot C trong Sheets("nhap_lieu") co trung voi C8 trong Sheets("CTGNM") hay khong?
            If Nhaplieu(I, 2) = Sheet17.Range("C8") Then
                K = K + 1: Ketqua(K, 1) = K     'Phan tu mang chua so thu tu
                'Dien du lieu tuong ung tu Sheets("nhap_lieu") vao mang Ketqua()
                Ketqua(K, 2) = Nhaplieu(I, 15): Ketqua(K, 3) = Nhaplieu(I, 4)
                Ketqua(K, 4) = Nhaplieu(I, 11): Ketqua(K, 5) = Nhaplieu(I, 6)
                Ketqua(K, 6) = Nhaplieu(I, 7)
            End If
        End If
    Next I
    
    'Xoa bo ket qua cu
    Sheet17.Range("B11:G23").ClearContents
    If K Then
        'Dien ket qua moi
        Sheet17.Range("B11").Resize(K, 6) = Ketqua
        MsgBox "Done", vbInformation, "GPE"
    Else
        MsgBox "Khong co du lieu thoa man", vbCritical, "GPE"
    End If
End Sub
 
vanthinh3101 đã viết:
Tôi viết 3 code, code nào bạn cần giải thích.
Tôi có viết chỉ dẫn ở code đầu tiên của bài #4 rồi, code thứ 2 thì tương tự code đầu tiên nhưng cách lấy dữ liệu ngược lại.
Code thứ 3:
PHP: 
Sub SochitietGNM()
    Dim Nhaplieu(), Ketqua()
    Dim I As Long, J As Long, K As Long
   
    'Tao mang chua du lieu tu cot B den cot P trong Sheets("nhap_lieu")
    Nhaplieu = Sheet82.Range("B9", Sheet82.Range("B9").End(xlDown)).Resize(, 15).Value
    'Khai bao kich thuoc mang ket qua
    ReDim Ketqua(1 To UBound(Nhaplieu, 1), 1 To 6)
   
    For I = 1 To UBound(Nhaplieu, 1)
        'Kiem tra gia tri cot B trong Sheets("nhap_lieu") co nam trong khoang thoi gian can loc hay khong?
        If Nhaplieu(I, 1) >= Sheet17.Range("D4") And Nhaplieu(I, 1) <= Sheet17.Range("D5") Then
            'Kiem tra gia tri cot C trong Sheets("nhap_lieu") co trung voi C8 trong Sheets("CTGNM") hay khong?
            If Nhaplieu(I, 2) = Sheet17.Range("C8") Then
                K = K + 1: Ketqua(K, 1) = K     'Phan tu mang chua so thu tu
                'Dien du lieu tuong ung tu Sheets("nhap_lieu") vao mang Ketqua()
                Ketqua(K, 2) = Nhaplieu(I, 15): Ketqua(K, 3) = Nhaplieu(I, 4)
                Ketqua(K, 4) = Nhaplieu(I, 11): Ketqua(K, 5) = Nhaplieu(I, 6)
                Ketqua(K, 6) = Nhaplieu(I, 7)
            End If
        End If
    Next I
   
    'Xoa bo ket qua cu
    Sheet17.Range("B11:G23").ClearContents
    If K Then
        'Dien ket qua moi
        Sheet17.Range("B11").Resize(K, 6) = Ketqua
        MsgBox "Done", vbInformation, "GPE"
    Else
        MsgBox "Khong co du lieu thoa man", vbCritical, "GPE"
    End If
End Sub
Nhấp chuột vào đây để mở rộng...
Dạ vâng. Đây đúng là code em cần anh giúp ạ. Em cảm ơn anh ạ
 
vanthinh3101 đã viết:
Tôi viết 3 code, code nào bạn cần giải thích.
Tôi có viết chỉ dẫn ở code đầu tiên của bài #4 rồi, code thứ 2 thì tương tự code đầu tiên nhưng cách lấy dữ liệu ngược lại.
Code thứ 3:
PHP: 
Sub SochitietGNM()
    Dim Nhaplieu(), Ketqua()
    Dim I As Long, J As Long, K As Long
   
    'Tao mang chua du lieu tu cot B den cot P trong Sheets("nhap_lieu")
    Nhaplieu = Sheet82.Range("B9", Sheet82.Range("B9").End(xlDown)).Resize(, 15).Value
    'Khai bao kich thuoc mang ket qua
    ReDim Ketqua(1 To UBound(Nhaplieu, 1), 1 To 6)
   
    For I = 1 To UBound(Nhaplieu, 1)
        'Kiem tra gia tri cot B trong Sheets("nhap_lieu") co nam trong khoang thoi gian can loc hay khong?
        If Nhaplieu(I, 1) >= Sheet17.Range("D4") And Nhaplieu(I, 1) <= Sheet17.Range("D5") Then
            'Kiem tra gia tri cot C trong Sheets("nhap_lieu") co trung voi C8 trong Sheets("CTGNM") hay khong?
            If Nhaplieu(I, 2) = Sheet17.Range("C8") Then
                K = K + 1: Ketqua(K, 1) = K     'Phan tu mang chua so thu tu
                'Dien du lieu tuong ung tu Sheets("nhap_lieu") vao mang Ketqua()
                Ketqua(K, 2) = Nhaplieu(I, 15): Ketqua(K, 3) = Nhaplieu(I, 4)
                Ketqua(K, 4) = Nhaplieu(I, 11): Ketqua(K, 5) = Nhaplieu(I, 6)
                Ketqua(K, 6) = Nhaplieu(I, 7)
            End If
        End If
    Next I
   
    'Xoa bo ket qua cu
    Sheet17.Range("B11:G23").ClearContents
    If K Then
        'Dien ket qua moi
        Sheet17.Range("B11").Resize(K, 6) = Ketqua
        MsgBox "Done", vbInformation, "GPE"
    Else
        MsgBox "Khong co du lieu thoa man", vbCritical, "GPE"
    End If
End Sub
Nhấp chuột vào đây để mở rộng...

Em chào anh. Anh làm ơn sửa code file excel này cho em được ko ạ. Em muốn lưu dữ liệu vào các cột H,I,J,K sheet nhap_lieu mà không được anh ạ
 

File đính kèm

  • VT_DC.xlsm
    182.2 KB · Đọc: 3
JungSangAh đã viết:
Em chào anh. Anh làm ơn sửa code file excel này cho em được ko ạ. Em muốn lưu dữ liệu vào các cột H,I,J,K sheet nhap_lieu mà không được anh ạ
Nhấp chuột vào đây để mở rộng...
Gửi lại bạn code Lưu.
Bạn lưu ý thông tin sheets("VTDC") ở cột B không có dữ liệu liên tiếp. Gặp trường hợp này thì phải tìm dòng cuối bằng cách đi ngược từ dưới lên
PHP: 
Sub Lenh_luu_nhaplieu_dasua()
    Dim SourceData As Variant, VTDC(), DEAN(), GetData(1 To 1, 1 To 12)
    Dim lR As Long, I As Long
    
    Application.ScreenUpdating = False
    lR = Sheet82.Range("B" & Rows.Count).End(xlUp).Row + 1 'Dong cuoi cot B
    VTDC = Sheet23.Range("B10:B" & Sheet23.Range("B" & Rows.Count).End(xlUp).Row).Resize(, 5).Value
    DEAN = Sheet83.Range("B10", Sheet83.Range("B10").End(xlDown)).Resize(, 5).Value
    SourceData = Array("", "C1", "C2", "C3", "", "C4", "C5", "", "C6", "", "", "", "")
    
    'Dien so thu tu
    If lR = 9 Then
        GetData(1, 1) = 1
    Else
        GetData(1, 1) = Sheet82.Range("A" & lR).Offset(-1).Value + 1
    End If
    
    'Lay cac thong tin tu cac o C1, C2,... vao mang ket qua
    For I = LBound(SourceData) To UBound(SourceData)
        If Len(SourceData(I)) Then GetData(1, I + 1) = Sheet82.Range(SourceData(I))
    Next I

    'Lay thong tin don vi nhan mau
    For I = 1 To UBound(DEAN, 1)
        If GetData(1, 4) = DEAN(I, 1) Then
            GetData(1, 5) = DEAN(I, 2)
            Exit For
        End If
    Next I
    
    'Lay thong tin VT_DC
    For I = 1 To UBound(VTDC, 1)
        If GetData(1, 7) = VTDC(I, 1) Then
            GetData(1, 8) = VTDC(I, 2): GetData(1, 10) = VTDC(I, 4)
            GetData(1, 11) = VTDC(I, 5)
            Exit For
        End If
    Next I
    
    'Tinh thanh tien
    GetData(1, 12) = GetData(1, 9) * GetData(1, 11)
    
    'Gan mang ket qua vao dong cuoi
    Sheet82.Range("A" & lR).Resize(, 12) = GetData

End Sub
Code lấy nội dung nhập liệu ở sự kiện Worksheet_Change bạn viết được rồi.
 
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

Emyeuexcel
  • Question
VBA lưu file, in, và mở lại file gốc ban đầu
Trả lời
0
Đọc
1
Emyeuexcel
Emyeuexcel
kyo
  • Suggestion
Bài viết: SAP Scripting – Excel và SAP (P2)
    • Thích
Trả lời
13
Đọc
8K
Tình nghĩa giang hồ
Tình nghĩa giang hồ
emlat3
Đặt màu xen kẽ các dòng theo ký tự
Trả lời
9
Đọc
176
ptm0412
ptm0412
A
Tính tổng dữ liệu băng dictionary
Trả lời
6
Đọc
91
DeTong
D
LuuAnh980
  • Question
Code lấy dữ liệu từ 3 file con.
2 3 4
Trả lời
65
Đọc
998
HUONGHCKT
H
Xem thêm…

Facebook

Giaiphapexcel.com

Group

DIỄN ĐÀN GIẢI PHÁP EXCEL Group 1
DIỄN ĐÀN GIẢI PHÁP EXCEL Group 2

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

Back
Top Bottom