Tạo msg box (1 người xem)

  • Thread starter Thread starter GTK-PM
  • Ngày gửi Ngày gửi
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)
GTK-PM

GTK-PM

Thành viên thường trực
Tham gia
10/11/13
Bài viết
313
Được thích
15
Mã: 
Option Explicit


Public Sub BC_LoaiVT()
Dim sArr(), dArr(1 To 100, 1 To 9), I As Long, K As Long, Tong As Long
Dim fDate As Long, eDate As Long, MaVT As String
With Sheets("Bc LoaiVatTu")
    fDate = .Range("E5").Value
    eDate = .Range("G5").Value
    MaVT = .Range("E6").Value
End With
'-----------------------------------------------
With Sheets("NHAP")
    sArr = .Range("C10", .Range("C10").End(xlDown)).Resize(, 17).Value
End With
For I = 1 To UBound(sArr)
    If sArr(I, 2) <= eDate Then
    If sArr(I, 2) >= fDate Then
        If sArr(I, 4) = MaVT Then
            K = K + 1
            dArr(K, 1) = sArr(I, 1): dArr(K, 2) = sArr(I, 2)
            dArr(K, 3) = sArr(I, 5): dArr(K, 5) = sArr(I, 12)
            dArr(K, 6) = sArr(I, 14): dArr(K, 9) = sArr(I, 17)
        End If


    End If
    End If
Next I
'--------------------------------------------
With Sheets("XUAT")
    sArr = .Range("C10", .Range("C10").End(xlDown)).Resize(, 16).Value
End With
For I = 1 To UBound(sArr)
    If sArr(I, 2) <= eDate Then
    If sArr(I, 2) >= fDate Then
        If sArr(I, 4) = MaVT Then
            K = K + 1
            dArr(K, 1) = sArr(I, 1): dArr(K, 2) = sArr(I, 2)
            dArr(K, 5) = sArr(I, 11)
            dArr(K, 7) = sArr(I, 13): dArr(K, 9) = sArr(I, 16)
        End If
    End If
    End If
Next I
'-----------------------
With Sheets("Bc LoaiVatTu")
    .Range("B12").Resize(K, 9) = dArr
    .Range("B12").Resize(K, 9).Sort Key1:=.Range("C12")
    sArr = .Range("B12:J12").Resize(K).Value
    For I = 1 To K
        Tong = Tong + sArr(I, 6) - sArr(I, 7)
        sArr(I, 8) = Tong
    Next I
    .Range("B12").Resize(K, 9) = sArr
      .Rows("12:450").EntireRow.Hidden = False
.Rows(12 + K & ":450").EntireRow.Hidden = True
.Range("B12:J450").ClearContents
.Range("B12").Resize(K, 9) = sArr
[E6].Interior.ColorIndex = 34 + 9 * Rnd() \ 1
End With
End Sub



Nhờ anh chị tạo giúp em msgbox khi không tìm thấy dữ liệu vào đoạn code trên ! Em mò mãi không tạo được.
 
Sắp xếp theo thời gian sắp xếp theo bầu chọn
Trước câu lệnh:
Mã: 
With Sheets("Bc LoaiVatTu")
Bạn thêm các câu lệnh sau:
PHP: 
 If K<1 then
    MsgBox "Khong Du Lieu Duoc Tìm Tháy!",,"GPE.COM"
 End If
 
Upvote 0
HYen17 đã viết:
Trước câu lệnh:
Mã: 
With Sheets("Bc LoaiVatTu")
Bạn thêm các câu lệnh sau:
PHP: 
 If K<1 then
    MsgBox "Khong Du Lieu Duoc Tìm Tháy!",,"GPE.COM"
 End If
Nhấp chuột vào đây để mở rộng...

anhloi1.jpg

Chèn trước câu lệnh bạn đã hướng dẫn, thì msg box hiện nội dụng :"Khong Du Lieu Duoc Tìm Tháy!",,"GPE.COM" và đằng sau là hình ảnh kia, bạn chỉ mình cách ẩn nốt bảng thông báo kia k?
 
Upvote 0
Bạn bấm chuột vô nút có chữ 'D' xem nó báo dòng lệnh nào lỗi.
 
Upvote 0
aicungyeuanh đã viết:
View attachment 161946

Gửi bạn ! Bạn xem giúp mình đây là ntn?????
Nhấp chuột vào đây để mở rộng...

Bạn chế lại code "mắc cười" quá.
PHP: 
With Sheets("Bc LoaiVatTu")
    .Range("B12").Resize(K, 9) = dArr
    .Range("B12").Resize(K, 9).Sort Key1:=.Range("C12")
    sArr = .Range("B12:J12").Resize(K).Value
    For I = 1 To K
        Tong = Tong + sArr(I, 6) - sArr(I, 7)
        sArr(I, 8) = Tong
    Next I
    .Range("B12").Resize(K, 9) = sArr      '-----------Gán kết quả'
      .Rows("12:450").EntireRow.Hidden = False
.Rows(12 + K & ":450").EntireRow.Hidden = True
.Range("B12:J450").ClearContents           'Xoá kết quả'
.Range("B12").Resize(K, 9) = sArr   '------------------lại gán kết quả'
[E6].Interior.ColorIndex = 34 + 9 * Rnd() \ 1
End With
End Sub
Lỗi trên là thiếu 1 dòng:
If K ...........
MsgBox "........."
Exit Sub <-----------Thêm dòng này sau dòng MsgBox
End If
 
Lần chỉnh sửa cuối:
Upvote 0
Ba Tê đã viết:
Bạn chế lại code "mắc cười" quá.
PHP: 
With Sheets("Bc LoaiVatTu")
    .Range("B12").Resize(K, 9) = dArr
    .Range("B12").Resize(K, 9).Sort Key1:=.Range("C12")
    sArr = .Range("B12:J12").Resize(K).Value
    For I = 1 To K
        Tong = Tong + sArr(I, 6) - sArr(I, 7)
        sArr(I, 8) = Tong
    Next I
    .Range("B12").Resize(K, 9) = sArr      '-----------Gán kết quả'
      .Rows("12:450").EntireRow.Hidden = False
.Rows(12 + K & ":450").EntireRow.Hidden = True
.Range("B12:J450").ClearContents           'Xoá kết quả'
.Range("B12").Resize(K, 9) = sArr   '------------------lại gán kết quả'
[E6].Interior.ColorIndex = 34 + 9 * Rnd() \ 1
End With
End Sub
Lỗi trên là thiếu 1 dòng:
If K ...........
MsgBox "........."
Exit Sub <-----------Thêm dòng này sau dòng MsgBox
End If
Nhấp chuột vào đây để mở rộng...

loiloi3.jpg

Sheet này của em khi có dữ liệu thì tìm kiếm được, nhưng không có dữ liệu lại báo lỗi này, bác xem giùm em.
P/s: Klq nhưng Pháp thua rồi :((
 
Lần chỉnh sửa cuối:
Upvote 0
Ba Tê đã viết:
Bạn chế lại code "mắc cười" quá.
PHP: 
With Sheets("Bc LoaiVatTu")
    .Range("B12").Resize(K, 9) = dArr
    .Range("B12").Resize(K, 9).Sort Key1:=.Range("C12")
    sArr = .Range("B12:J12").Resize(K).Value
    For I = 1 To K
        Tong = Tong + sArr(I, 6) - sArr(I, 7)
        sArr(I, 8) = Tong
    Next I
    .Range("B12").Resize(K, 9) = sArr      '-----------Gán kết quả'
      .Rows("12:450").EntireRow.Hidden = False
.Rows(12 + K & ":450").EntireRow.Hidden = True
.Range("B12:J450").ClearContents           'Xoá kết quả'
.Range("B12").Resize(K, 9) = sArr   '------------------lại gán kết quả'
[E6].Interior.ColorIndex = 34 + 9 * Rnd() \ 1
End With
End Sub
Lỗi trên là thiếu 1 dòng:
If K ...........
MsgBox "........."
Exit Sub <-----------Thêm dòng này sau dòng MsgBox
End If
Nhấp chuột vào đây để mở rộng...

Sheet này của em khi có dữ liệu thì tìm kiếm được, nhưng không có dữ liệu lại báo lỗi này, bác xem giùm em.
P/s: Klq nhưng Pháp thua rồi :((
 
Upvote 0
aicungyeuanh đã viết:
Sheet này của em khi có dữ liệu thì tìm kiếm được, nhưng không có dữ liệu lại báo lỗi này, bác xem giùm em.
P/s: Klq nhưng Pháp thua rồi :((
Nhấp chuột vào đây để mở rộng...

Thay đoạn đó bằng đoạn này:
PHP: 
With Sheets("Bc LoaiVatTu")
    .Rows("12:450").EntireRow.Hidden = False
    .Range("B12:J450").ClearContents
    If K Then
        .Range("B12").Resize(K, 9) = dArr
        .Range("B12").Resize(K, 9).Sort Key1:=.Range("C12")
        sArr = .Range("B12:J12").Resize(K).Value
        For I = 1 To K
            Tong = Tong + sArr(I, 6) - sArr(I, 7)
            sArr(I, 8) = Tong
        Next I
        .Range("B12").Resize(K, 9) = sArr
    Else
        MsgBox "Khong co so lieu.", , "GPE"
    End If
        .Rows(12 + K & ":450").EntireRow.Hidden = True
End With
End Sub
Nếu bạn làm không được thì đưa file thật lên, chứ đưa code lên ít ai chịu đọc, suy nghĩ, để tìm ra chỗ bạn "chế thêm".
 
Upvote 0
Ba Tê đã viết:
Thay đoạn đó bằng đoạn này:
PHP: 
With Sheets("Bc LoaiVatTu")
    .Rows("12:450").EntireRow.Hidden = False
    .Range("B12:J450").ClearContents
    If K Then
        .Range("B12").Resize(K, 9) = dArr
        .Range("B12").Resize(K, 9).Sort Key1:=.Range("C12")
        sArr = .Range("B12:J12").Resize(K).Value
        For I = 1 To K
            Tong = Tong + sArr(I, 6) - sArr(I, 7)
            sArr(I, 8) = Tong
        Next I
        .Range("B12").Resize(K, 9) = sArr
    Else
        MsgBox "Khong co so lieu.", , "GPE"
    End If
        .Rows(12 + K & ":450").EntireRow.Hidden = True
End With
End Sub
Nếu bạn làm không được thì đưa file thật lên, chứ đưa code lên ít ai chịu đọc, suy nghĩ, để tìm ra chỗ bạn "chế thêm".
Nhấp chuột vào đây để mở rộng...
loiloi3.jpg


Bên BC Hang mục bị lỗi như này, nhờ bác chỉ giáo

Mã: 
Option Explicit




Public Sub BC_HangMuc()
Dim Dic As Object, sArr(), dArr(), I As Long, J As Long, K As Long, Rws As Long
Dim KQ, Tam, T As Long
Dim fDate As Long, eDate As Long, MaHM As String, Tem As String
Set Dic = CreateObject("Scripting.Dictionary")
With Sheets("BC HANGMUC")
    fDate = .Range("G6").Value
    eDate = .Range("G7").Value
    MaHM = .Range("J6").Value
End With
'-----------------------------------------------
With Sheets("DANHMUC")
    sArr = .Range("C7", .Range("C65000").End(xlUp)).Resize(, 4).Value
End With
ReDim dArr(1 To UBound(sArr), 1 To 8)
For I = 1 To UBound(sArr)
    If sArr(I, 1) <> Empty Then
        K = K + 1: dArr(K, 1) = K
        Dic.Item(sArr(I, 1)) = K
        For J = 1 To 3
            dArr(K, J + 1) = sArr(I, J)
        Next J
    End If
Next I
'-----------------------------------------------
With Sheets("NHAP")
    sArr = .Range("D10", .Range("D10").End(xlDown)).Resize(, 16).Value
End With
For I = 1 To UBound(sArr)
    If sArr(I, 1) <= eDate Then
    If sArr(I, 1) >= fDate Then
    If sArr(I, 16) = MaHM Then
        If Dic.Exists(sArr(I, 3)) Then
            Rws = Dic.Item(sArr(I, 3))
            dArr(Rws, 6) = dArr(Rws, 6) + sArr(I, 13)
            dArr(Rws, 8) = dArr(Rws, 6) - dArr(Rws, 7)
        End If
    End If
    End If
    End If
Next I
'--------------------------------------------
With Sheets("XUAT")
    sArr = .Range("D10", .Range("D10").End(xlDown)).Resize(, 15).Value
End With
For I = 1 To UBound(sArr)
    If sArr(I, 1) <= eDate Then
    If sArr(I, 1) >= fDate Then
    If sArr(I, 15) = MaHM Then
        If Dic.Exists(sArr(I, 3)) Then
            Rws = Dic.Item(sArr(I, 3))
            dArr(Rws, 7) = dArr(Rws, 7) + sArr(I, 12)
            dArr(Rws, 8) = dArr(Rws, 6) - dArr(Rws, 7)
        End If
    End If
    End If
    End If
Next I
'---------------------------------------------
ReDim KQ(1 To K + 1, 1 To 8)
    For I = 1 To K
        Tam = 0
        For J = 5 To 8
            Tam = Tam + dArr(I, J)
        Next J
        If Tam > 0 Then
            T = T + 1
                KQ(T, 1) = T
            For J = 2 To 8
                KQ(T, J) = dArr(I, J)
            Next J
        End If
    Next I
'-----------------------
With Sheets("BC HANGMUC")
    .Range("B12").Resize(450, 8).ClearContents
    .Range("B12").Resize(T, 8) = KQ
    Rows("12:450").Hidden = False
    Rows([B450].End(xlUp).Offset(1).Row & ":450").Hidden = True
        
End With
Set Dic = Nothing
End Sub
 
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

A
Xin các bác chỉ giúp cách thống kê danh sách học sinh
Trả lời
0
Đọc
16
Anhnn9
A
T
xin công thức tính được số người còn lại theo từng cột
Trả lời
0
Đọc
16
tadung2710
T
P
  • Question Question
Lấy giá trị duy nhất nhiều cột khác nhau
Trả lời
1
Đọc
18
BuiQuangThuan
B
T
hỏi về đếm số ngày doanh thu tăng và giảm
Trả lời
2
Đọc
22
VetMini
V
A
  • Question Question
Em nhờ anh/chị/em/chú/bác giúp em viết code tổng hợp dữ liệu. em tính công thức nó nặng quá. em cám ơn
Trả lời
8
Đọc
131
VetMini
V
D
Hỏi về cách sử dụng data table
Trả lời
0
Đọc
17
duymax1234567
D
hieuxd
  • Question Question
Khi nhập dữ liệu tự động chèn thêm dòng khi số dòng trong bảng mẫu sắp hết
2
Trả lời
21
Đọc
24K
Bát Giới
Bát Giới
4
EXCEL TỰ ĐỘNG MỞ TRÊN WEB
Trả lời
1
Đọc
61
HeSanbi
HeSanbi
Nguyễn Duy Tuân
Lập trình VBA với Google Drive, OneDrive, DropBox cho Upload-Download-Copy-Move...
Trả lời
0
Đọc
68
Nguyễn Duy Tuân
Nguyễn Duy Tuân
TrungChinhs
  • Question Question
Hỏi cách làm tròn số trong VBA
Trả lời
10
Đọc
7K
VetMini
V
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 (1 người xem)
Trả lời
15
Đọc
289
ptm0412
ptm0412
dangvandang
Addin mở rộng cho xây dựng
    • Thích
2
Trả lời
34
Đọc
3K
vlba
V
M
  • Question Question
Tự chèn dòng khi cập nhật dữ liệu từ trang tính khác.
Trả lời
4
Đọc
136
mtbackup
M
N
Xin giúp e cách lọc dữ liệu bị trùng
Trả lời
3
Đọc
174
hoangtuaotrang_hp_vn
H
A
ExTools : Hơn 60 tính năng bổ sung cho Excel
    • Thích
Trả lời
3
Đọc
9K
mangat060083
M
anhtuan1066
  • Question Question
Đọc số thành chữ có phần thập phân
Trả lời
12
Đọc
8K
caocat
C
A
  • Question Question
Nhờ anh chị em chú bác giúp em viết code vba thay cho công thức dò tìm và tính
Trả lời
2
Đọc
126
A HOANG 620
A
ongke0711
  • Question Question
Trộn dữ liệu từ Excel sang Word mở rộng (phiên bản ongke0711)
    • Thích
    • Yêu thích
    • Cảm ơn
12 13 14
Trả lời
262
Đọc
28K
toptikibeauty
T
T
tìm ra số tháng mà lượng hàng nhập ban đầu sử dụng hết
    • Cười
Trả lời
3
Đọc
160
minhminh27
minhminh27
nttrung_proneu
Cách giữ công thức khi lọc và tách file
Trả lời
2
Đọc
108
nttrung_proneu
nttrung_proneu
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