Chuyên mục xử lý, gỡ rối code VBA (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)
Status
Không mở trả lời sau này.
ndu96081631

ndu96081631

Huyền thoại GPE
Thành viên BQT
Super Moderator
Tham gia
5/6/08
Bài viết
30,703
Được thích
53,970
Sắp xếp theo thời gian sắp xếp theo bầu chọn
Em có một thắc mắc tại sao khi chạy code VBA thì ta sẽ không thể Undo lại được nữa?
 
Upvote 0
Mọi người chỉ giúp em với, em muốn paste dữ liệu từ cột clipboard vào useform nhưng không được, mọi người có cách nào không ?
 

File đính kèm

  • test.xlsm
    test.xlsm
    17.7 KB · Đọc: 1
  • 22552606_1855092237851758_1999908251608793798_n.jpg
    22552606_1855092237851758_1999908251608793798_n.jpg
    62.2 KB · Đọc: 5
Upvote 0
Em có mượn code của thầy Ndu và sửa thành
PHP: 
Dim Temp as Object

  Set Temp = CreateObject("VBScript.RegExp")
  Temp.Global = True
  Temp.Pattern = "[^0-9]"

...
dArr(K, 2) = dArr(K, 2) + Temp.Replace(sArr(i, j), "")

Với mục đích tách và tính tổng nhưng kết quả chỉ ra một dãy số là các số được tách là sao ạ?
 
Upvote 0
Trunghieutin10 đã viết:
Nó Default rồi bạn ak. Còn sâu bên trong nữa chắc hỏi ông viết ra cái này :)
Nhấp chuột vào đây để mở rộng...
Mình hiểu là nó thay hết chữ thành khoảng trống. Vậy như công thức mảng trên thì thay xong ra một con số, sau đó chuyển sang ô tiếp theo lại tách tiếp ra một con số và con số này cộng với con số trước đó. Kì lạ là nó không như cách mình hiểu.
 
Upvote 0
Em học lỏm thêm được như sau

dArr(K, 2) = Evaluate(dArr(K, 2))

Mà chẳng hiểu sao lại cần như vậy :((
 
Upvote 0
Xin các anh chị chỉnh dùm đoạn code sau, mới học, còn yếu lắm, rất cảm ơn. Em thấy nó không được gọn mà em chưa biết dùng for...next trong trường hợp này. Xin anh chị tận tình chỉ giúp.

Private Sub CommandButton1_Click()
Dim TT As Boolean
TT = MsgBox("Hanh dong nay se xoa toan bo du lieu da nhap truoc day. Bam OK de xoa du lieu cu, nhap du lieu moi. Bam CANCEL de tiep tuc dung du lieu truoc day!", vbOKCancel, "CHU Y!")
If TT = True Then
pass = Application.InputBox("Xin nhap password")
If pass = "123" Then
Sheet1.Range("D6:F11").ClearContents
Sheet2.Range("A5:r40").ClearContents
Sheet3.Range("i5:l40").ClearContents
Sheet3.Range("P5:p40").ClearContents
Sheet3.Range("r5:r40").ClearContents
Sheet3.Range("t5:t40").ClearContents
Sheet3.Range("u5:y40").ClearContents
Sheet3.Range("aa5:aa40").ClearContents
Sheet3.Range("ac5:ac40").ClearContents
Sheet3.Range("ae5:ae40").ClearContents
Sheet3.Range("af5:al40").ClearContents
Sheet5.Range("i5:l40").ClearContents
Sheet5.Range("P5:p40").ClearContents
Sheet5.Range("r5:r40").ClearContents
Sheet5.Range("t5:t40").ClearContents
Sheet5.Range("u5:y40").ClearContents
Sheet5.Range("aa5:aa40").ClearContents
Sheet5.Range("ac5:ac40").ClearContents
Sheet5.Range("ae5:ae40").ClearContents
Sheet5.Range("af5:al40").ClearContents
Sheet7.Range("i5:l40").ClearContents
Sheet7.Range("P5:p40").ClearContents
Sheet7.Range("r5:r40").ClearContents
Sheet7.Range("t5:t40").ClearContents
Sheet7.Range("u5:y40").ClearContents
Sheet7.Range("aa5:aa40").ClearContents
Sheet7.Range("ac5:ac40").ClearContents
Sheet7.Range("ae5:ae40").ClearContents
Sheet7.Range("af5:al40").ClearContents
Sheet9.Range("i5:l40").ClearContents
Sheet9.Range("P5:p40").ClearContents
Sheet9.Range("r5:r40").ClearContents
Sheet9.Range("t5:t40").ClearContents
Sheet9.Range("u5:y40").ClearContents
Sheet9.Range("aa5:aa40").ClearContents
Sheet9.Range("ac5:ac40").ClearContents
Sheet9.Range("ae5:ae40").ClearContents
Sheet9.Range("af5:al40").ClearContents
Else
MsgBox ("Sai mat khau!")
End If
End If
End Sub
 
Upvote 0
DavidChau đã viết:
Xin các anh chị chỉnh dùm đoạn code sau, mới học, còn yếu lắm, rất cảm ơn. Em thấy nó không được gọn mà em chưa biết dùng for...next trong trường hợp này. Xin anh chị tận tình chỉ giúp.

Private Sub CommandButton1_Click()
Dim TT As Boolean
TT = MsgBox("Hanh dong nay se xoa toan bo du lieu da nhap truoc day. Bam OK de xoa du lieu cu, nhap du lieu moi. Bam CANCEL de tiep tuc dung du lieu truoc day!", vbOKCancel, "CHU Y!")
If TT = True Then
pass = Application.InputBox("Xin nhap password")
If pass = "123" Then
Sheet1.Range("D6:F11").ClearContents
Sheet2.Range("A5:r40").ClearContents
Sheet3.Range("i5:l40").ClearContents
Sheet3.Range("P5:p40").ClearContents
Sheet3.Range("r5:r40").ClearContents
Sheet3.Range("t5:t40").ClearContents
Sheet3.Range("u5:y40").ClearContents
Sheet3.Range("aa5:aa40").ClearContents
Sheet3.Range("ac5:ac40").ClearContents
Sheet3.Range("ae5:ae40").ClearContents
Sheet3.Range("af5:al40").ClearContents
Sheet5.Range("i5:l40").ClearContents
Sheet5.Range("P5:p40").ClearContents
Sheet5.Range("r5:r40").ClearContents
Sheet5.Range("t5:t40").ClearContents
Sheet5.Range("u5:y40").ClearContents
Sheet5.Range("aa5:aa40").ClearContents
Sheet5.Range("ac5:ac40").ClearContents
Sheet5.Range("ae5:ae40").ClearContents
Sheet5.Range("af5:al40").ClearContents
Sheet7.Range("i5:l40").ClearContents
Sheet7.Range("P5:p40").ClearContents
Sheet7.Range("r5:r40").ClearContents
Sheet7.Range("t5:t40").ClearContents
Sheet7.Range("u5:y40").ClearContents
Sheet7.Range("aa5:aa40").ClearContents
Sheet7.Range("ac5:ac40").ClearContents
Sheet7.Range("ae5:ae40").ClearContents
Sheet7.Range("af5:al40").ClearContents
Sheet9.Range("i5:l40").ClearContents
Sheet9.Range("P5:p40").ClearContents
Sheet9.Range("r5:r40").ClearContents
Sheet9.Range("t5:t40").ClearContents
Sheet9.Range("u5:y40").ClearContents
Sheet9.Range("aa5:aa40").ClearContents
Sheet9.Range("ac5:ac40").ClearContents
Sheet9.Range("ae5:ae40").ClearContents
Sheet9.Range("af5:al40").ClearContents
Else
MsgBox ("Sai mat khau!")
End If
End If
End Sub
Nhấp chuột vào đây để mở rộng...
Có lẽ bạn nên up file
 
Upvote 0
DavidChau đã viết:
Xin các anh chị chỉnh dùm đoạn code sau, mới học, còn yếu lắm, rất cảm ơn. Em thấy nó không được gọn mà em chưa biết dùng for...next trong trường hợp này. Xin anh chị tận tình chỉ giúp.

Private Sub CommandButton1_Click()
Dim TT As Boolean
TT = MsgBox("Hanh dong nay se xoa toan bo du lieu da nhap truoc day. Bam OK de xoa du lieu cu, nhap du lieu moi. Bam CANCEL de tiep tuc dung du lieu truoc day!", vbOKCancel, "CHU Y!")
If TT = True Then
pass = Application.InputBox("Xin nhap password")
If pass = "123" Then
Sheet1.Range("D6:F11").ClearContents
Sheet2.Range("A5:r40").ClearContents
Sheet3.Range("i5:l40").ClearContents
Sheet3.Range("P5:p40").ClearContents
Sheet3.Range("r5:r40").ClearContents
Sheet3.Range("t5:t40").ClearContents
Sheet3.Range("u5:y40").ClearContents
Sheet3.Range("aa5:aa40").ClearContents
Sheet3.Range("ac5:ac40").ClearContents
Sheet3.Range("ae5:ae40").ClearContents
Sheet3.Range("af5:al40").ClearContents
Sheet5.Range("i5:l40").ClearContents
Sheet5.Range("P5:p40").ClearContents
Sheet5.Range("r5:r40").ClearContents
Sheet5.Range("t5:t40").ClearContents
Sheet5.Range("u5:y40").ClearContents
Sheet5.Range("aa5:aa40").ClearContents
Sheet5.Range("ac5:ac40").ClearContents
Sheet5.Range("ae5:ae40").ClearContents
Sheet5.Range("af5:al40").ClearContents
Sheet7.Range("i5:l40").ClearContents
Sheet7.Range("P5:p40").ClearContents
Sheet7.Range("r5:r40").ClearContents
Sheet7.Range("t5:t40").ClearContents
Sheet7.Range("u5:y40").ClearContents
Sheet7.Range("aa5:aa40").ClearContents
Sheet7.Range("ac5:ac40").ClearContents
Sheet7.Range("ae5:ae40").ClearContents
Sheet7.Range("af5:al40").ClearContents
Sheet9.Range("i5:l40").ClearContents
Sheet9.Range("P5:p40").ClearContents
Sheet9.Range("r5:r40").ClearContents
Sheet9.Range("t5:t40").ClearContents
Sheet9.Range("u5:y40").ClearContents
Sheet9.Range("aa5:aa40").ClearContents
Sheet9.Range("ac5:ac40").ClearContents
Sheet9.Range("ae5:ae40").ClearContents
Sheet9.Range("af5:al40").ClearContents
Else
MsgBox ("Sai mat khau!")
End If
End If
End Sub
Nhấp chuột vào đây để mở rộng...
Bạn thử Code dưới đây xem sao
Mã: 
Private Sub CommandButton1_Click()
Dim TT As Boolean, i As Long
TT = MsgBox("Hanh dong nay se xoa toan bo du lieu da nhap truoc day. Bam OK de xoa du lieu cu, nhap du lieu moi. Bam CANCEL de tiep tuc dung du lieu truoc day!", vbOKCancel, "CHU Y!")
If TT = True Then
pass = Application.InputBox("Xin nhap password")
If pass = "123" Then
    Sheet1.Range("D6:F11").ClearContents
    Sheet2.Range("A5:r40").ClearContents
    For i = 3 To 9
        With Sheets(i)
            .Range("i5:l40").ClearContents
            .Range("P5:p40").ClearContents
            .Range("r5:r40").ClearContents
            .Range("t5:t40").ClearContents
            .Range("u5:y40").ClearContents
            .Range("aa5:aa40").ClearContents
            .Range("ac5:ac40").ClearContents
            .Range("ae5:ae40").ClearContents
            .Range("af5:al40").ClearContents
    End With
    Next
Else
    MsgBox ("Sai mat khau!")
End If
End If
End Sub
 
Upvote 0
DavidChau đã viết:
được gọn
Nhấp chuột vào đây để mở rộng...
Bạn đang gọi tới Sheet qua CodeName nên dùng cách sau. ;)
PHP: 
Sub ClearRange(ByVal ws As Worksheet)
    With ws
        Union(.Range("P5:P40"), .Range("R5:R40"), .Range("T5:T40"), .Range("U5:Y40"), _
                .Range("AA5:AA40"), .Range("AC5:AC40"), .Range("AE5:AE40"), .Range("AF5:AL40")).ClearContents
    End With
End Sub

Private Sub CommandButton1_Click()
    '....'
    If pass = "123" Then
        Sheet1.Range("D6:F11").ClearContents
        Sheet2.Range("A5:R40").ClearContents
        ClearRange Sheet3
        ClearRange Sheet5
        ClearRange Sheet7
        ClearRange Sheet9
    Else
    '....'
End Sub
 
Upvote 0
befaint đã viết:
Bạn đang gọi tới Sheet qua CodeName nên dùng cách sau. ;)
PHP: 
Sub ClearRange(ByVal ws As Worksheet)
    With ws
        Union(.Range("P5:P40"), .Range("R5:R40"), .Range("T5:T40"), .Range("U5:Y40"), _
                .Range("AA5:AA40"), .Range("AC5:AC40"), .Range("AE5:AE40"), .Range("AF5:AL40")).ClearContents
    End With
End Sub

Private Sub CommandButton1_Click()
    '....'
    If pass = "123" Then
        Sheet1.Range("D6:F11").ClearContents
        Sheet2.Range("A5:R40").ClearContents
        ClearRange Sheet3
        ClearRange Sheet5
        ClearRange Sheet7
        ClearRange Sheet9
    Else
    '....'
End Sub
Nhấp chuột vào đây để mở rộng...

ủa rồi For ... Next nằm ở chỗ nào vậy anh gì ơi ? +-+-+-++-+-+-+
 
Upvote 0
AutoReply đã viết:
ủa rồi For ... Next nằm ở chỗ nào vậy anh gì ơi ? +-+-+-++-+-+-+
Nhấp chuột vào đây để mở rộng...
Muốn có For ... Next thì thêm vào thôi -+*/
Mã: 
Sub ClearRange(ByVal ws As Worksheet, i)
    With ws
        Union(.Range("P5:P40"), .Range("R5:R40"), .Range("T5:T40"), .Range("U5:Y40"), _
                .Range("AA5:AA40"), .Range("AC5:AC40"), .Range("AE5:AE40"), .Range("AF5:AL40")).ClearContents
    End With
    i = Len("AutoHello")
End Sub

Private Sub CommandButton1_Click()
    '....'
    'If pass = "123" Then
        Sheet1.Range("D6:F11").ClearContents
        Sheet2.Range("A5:R40").ClearContents
        For i = 1 To 9
          ClearRange Sheet3, i
          ClearRange Sheet5, i
          ClearRange Sheet7, i
          ClearRange Sheet9, i
          i = i
        Next i
    'Else
    '....'
End Sub
 
Upvote 0
Chao các anh!
Em có file giải lập bên dưới mục đích cũa em là:
- em cần copy dư liệu bên sheet "Index" vao các sheet "1,2,3,4..." tương ứng các ngày trong tháng VD: ngày mùng 03.10/2017 thì khi nhấn nút " nhap du lieu" thì sẻ chép dử liệu vào sheet("3") ( điều kiện lấy ở Ô "NGAY THANG")
// Sheets("locNT") với locNT=left(NGAYTHANG,..).value đại loại là thế.
THANK MỌI NGƯỜI.
 

File đính kèm

Upvote 0
Bạn nên đổi lại tên các trang tính, như N01, N02,. . . N10,. . . .
& tham khảo macro sau:
PHP: 
Sub TestCopy_GPE()
 Dim ShName As String
 ShName = "N" & Right("0" & CStr(Day([i1].Value)), 2)
 MsgBox ShName
 Sheets("Index").[K11:P11].Copy Destination:=Sheets(ShName).[D12]
 MsgBox "Chép Thành Công!"
End Sub
 
Upvote 0
Hoang2013 đã viết:
Bạn nên đổi lại tên các trang tính, như N01, N02,. . . N10,. . . .
& tham khảo macro sau:
PHP: 
Sub TestCopy_GPE()
 Dim ShName As String
 ShName = "N" & Right("0" & CStr(Day([i1].Value)), 2)
 MsgBox ShName
 Sheets("Index").[K11:P11].Copy Destination:=Sheets(ShName).[D12]
 MsgBox "Chép Thành Công!"
End Sub
Nhấp chuột vào đây để mở rộng...
Cảm ơn bạn Hoang2013 đã chi share, tên sheet mặc định cũa cty mặc định là “1,2,3,4..” theo 30 ngày trong tháng nên mình kg can thiệp vào đc chuyện đó.
 
Upvote 0
SA_DQ đã viết:
Vậy thì 1 trong 2 thứ í bị bệnh nặng lắm rồi: Excel hay Code của bạn!
Nếu là do Excel, thì cài lại;
Nếu là do Code thì nên đưa lên diễn đàn để i bác sỹ hội chẩn cho.

Chúc vui!
Nhấp chuột vào đây để mở rộng...
Dạ code của em đây ah. Nhờ mọi người xem giùm ah.
Modul loc_du_lieu chạy bình thường ah. Modul tan_suat_hd thì khi chạy là bị reset file excel ah.
 

File đính kèm

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

Private Sub CommandButton1_Click()

Dim endR As Long
With Sheets("sheet2")
endR = .Range("B" & Rows.Count).End(xlUp).Row

.Range("B" & endR + 1) = tensanpham.Text
.Range("C" & endR + 1).Select
.Range("D" & endR + 1) = thanhphan.Text
.Range("E" & endR + 1) = luatuoisudung.Text
.Range("F" & endR + 1) = cachdung.Text
.Range("G" & endR + 1) = xuatxu.Text
.Range("H" & endR + 1) = hang.Text
.Range("I" & endR + 1) = mucdich.Text

End With

tensanpham.Text = ""
thanhphan.Text = ""
luatuoisudung.Text = ""
cachdung.Text = ""
xuatxu.Text = ""
hang.Text = ""
mucdich.Text = ""


Dim strfile As String
Dim rng As Range
Dim sh As Shape
Const cfile As String = "imagefiles(*.bmp;*.gif;*.jpg;*.jpeg;*.png),"
strfile = Application.GetOpenFilename(filefilter:=cfile, Title:=es)
If strfile = "false" Then
Else
Set rng = ActiveCell
Set rng = rng.MergeArea
With rng
Set sh = ActiveSheet.Shapes.AddPicture(Filename:=strfile, linktofile:=msoFalse, savewithdocument:=msoTrue, Left:=.Left, Top:=.Top, Width:=.Width, Height:=.Height)

sh.LockAspectRatio = msoFalse
End With
Set sh = Nothing
Set rng = Nothing
End If


tensanpham.SetFocus

End Sub

mình bị báo lỗi như thế này bạn check hộ mình nhé
 

File đính kèm

  • 2.png
    2.png
    128.1 KB · Đọc: 4
  • Untitled.png
    Untitled.png
    132.4 KB · Đọc: 4
Upvote 0
đây là file excel nếu bác cần :( xem hộ em nhé cần gấp lắm
 

File đính kèm

Upvote 0
Mong được giải đáp
Tôi có làm các checkbox để ẩn hiện các cột cho tiện (như file đính kèm).
Việc sử dụng thì không sao. Tuy nhiên khi mở file ra, cấu hình trong form không đúng với thực tế. Cụ thể là khi bấm dấu kiểm nào đó vào thì 1 số cột tương ứng bị ẩn, nếu đóng file lại và có save sau đó mở ra, cột vẫn bị ẩn mà dấu kiểm không còn.
Có cách nào lưu giữ dấu kiểm khi mở file tương ứng với khi đóng file ?
Xin cảm ơn
 

File đính kèm

Upvote 0
trungcr105 đã viết:
Chào mọi người em đang gặp khó với VBA mong mọi người giúp đỡ với ah!

em muốn làm phần Hyperlink trong cột "File" thì phải làm thế nào ah, em mày mò hoài mà không ra được phần đó.
Em tự mày mò nên cũng chỉ biết hạn chế, mong mọi người giúp đỡ ah
em xin chân thành cảm ơn!
Nhấp chuột vào đây để mở rộng...

có bác nào giúp e cái này với :(
 

File đính kèm

Upvote 0
Dạ code của em đây ah. Nhờ mọi người xem giùm ah.
Modul loc_du_lieu chạy bình thường ah. Modul tan_suat_hd thì khi chạy là bị reset file excel ah.
Nhấp chuột vào đây để mở rộng...
Mở module trước bình thường;
Mở cái bạn ghi sau nó báo lỗi "Error in loading DLL"
Đành chịu!
 
Upvote 0
befaint đã viết:
Bạn đang gọi tới Sheet qua CodeName nên dùng cách sau. ;)
PHP: 
Sub ClearRange(ByVal ws As Worksheet)
    With ws
        Union(.Range("P5:P40"), .Range("R5:R40"), .Range("T5:T40"), .Range("U5:Y40"), _
                .Range("AA5:AA40"), .Range("AC5:AC40"), .Range("AE5:AE40"), .Range("AF5:AL40")).ClearContents
    End With
End Sub

Private Sub CommandButton1_Click()
    '....'
    If pass = "123" Then
        Sheet1.Range("D6:F11").ClearContents
        Sheet2.Range("A5:R40").ClearContents
        ClearRange Sheet3
        ClearRange Sheet5
        ClearRange Sheet7
        ClearRange Sheet9
    Else
    '....'
End Sub
Nhấp chuột vào đây để mở rộng...
Rất cảm ơn bạn đã giúp đỡ. Tôi lại học được ở bạn một bài học mới.
 
Upvote 0
Hoang2013 đã viết:
Bạn nên đổi lại tên các trang tính, như N01, N02,. . . N10,. . . .
& tham khảo macro sau:
PHP: 
Sub TestCopy_GPE()
 Dim ShName As String
 ShName = "N" & Right("0" & CStr(Day([i1].Value)), 2)
 MsgBox ShName
 Sheets("Index").[K11:P11].Copy Destination:=Sheets(ShName).[D12]
 MsgBox "Chép Thành Công!"
End Sub
Nhấp chuột vào đây để mở rộng...
Nhờ các anh chỉ giúp mình muốn copy hàng dọc rồi paste vào hàng ngang trên VBA thì làm sao.
Và code " copy Destination" trên đó có y nghỉ gì?
Cảm Ơn mọi người giúp đở.
 

File đính kèm

Upvote 0
Em có đoạn code sau:
PHP: 
...
[AV9].Resize(Rws, 2).Value = FormatDateTime(dArr, vbShortTime)
...

Em muốn kết quả mảng trả về sẽ được định dạng dạng hh:mm, nhưng thử làm như vậy thì báo lỗi ở dòng này. Mọi người chỉ cho em nhé.
 
Upvote 0
befaint đã viết:
Bạn kết bạn với bạn @vova2209 ấy, để nhóm học...
Lần trước làm sao có kết quả ngay thì lần này cũng làm vậy...
Nhấp chuột vào đây để mở rộng...

À mình muốn định dạng luôn cái mảng, nếu làm như hôm trước thì phải thêm dòng lệnh nữa. Nên mình hỏi xem có cách nào gọn hơn không.
 
Upvote 0
tueyennhi đã viết:
À mình muốn định dạng luôn cái mảng, nếu làm như hôm trước thì phải thêm dòng lệnh nữa. Nên mình hỏi xem có cách nào gọn hơn không.
Nhấp chuột vào đây để mở rộng...
Vụ nầy ... bạn gởi Mail nhờ ngài Bill tạo thêm lệnh mới Format một lần 2 em Range và Array khác nhau hoàn toàn
 
Upvote 0
Đấy là hệ quả của việc không thích ABC... mà cứ thích chơi với Z....
http://www.giaiphapexcel.com/diendan/threads/nhờ-tạo-form-list-box-tìm-kiếm.130636/

Dữ liệu trong mảng chờ gán xuống bảng tính thì nó cũng như dữ liệu nhập từ bàn phím, chuột, copy/paste ở nguồn khác.... vào bảng tính.
Muốn trông dữ liệu trên bảng tính hình thù ra làm sao thì phải do định dạng trên bảng tính quyết định.
 
Upvote 0
Hoang2013 đã viết:
Mở module trước bình thường;
Mở cái bạn ghi sau nó báo lỗi "Error in loading DLL"
Đành chịu!
Nhấp chuột vào đây để mở rộng...
Dạ em sử dụng lệnh chỉ chạy office 2010 trở lên. 2007 ko chạy dc, nên báo lỗi Error in loading DLL.
em cài cả office 2007 và 2010 trên máy. ko biết có phải vì vậy mà khi chạy lệnh nó reset ko anh nhỉ?
 
Upvote 0
befaint đã viết:
Bạn đang gọi tới Sheet qua CodeName nên dùng cách sau. ;)
PHP: 
Sub ClearRange(ByVal ws As Worksheet)
    With ws
        Union(.Range("P5:P40"), .Range("R5:R40"), .Range("T5:T40"), .Range("U5:Y40"), _
                .Range("AA5:AA40"), .Range("AC5:AC40"), .Range("AE5:AE40"), .Range("AF5:AL40")).ClearContents
    End With
End Sub

Private Sub CommandButton1_Click()
    '....'
    If pass = "123" Then
        Sheet1.Range("D6:F11").ClearContents
        Sheet2.Range("A5:R40").ClearContents
        ClearRange Sheet3
        ClearRange Sheet5
        ClearRange Sheet7
        ClearRange Sheet9
    Else
    '....'
End Sub
Nhấp chuột vào đây để mở rộng...
Rất cảm ơn YOU, code chạy rất tốt. Xin YOU dành chút thì giờ giải thích dùm đoạn code để em út học hỏi kinh nghiệm. Rất mong sự giải thích của YOU. Cảm ơn nhiều lắm.
Sub ClearRange(ByVal ws As Worksheet)
With ws
Union(.Range("P5:P40"), .Range("R5:R40"), .Range("T5:T40"), .Range("U5:Y40"), _
.Range("AA5:AA40"), .Range("AC5:AC40"), .Range("AE5:AE40"), .Range("AF5:AL40")).ClearContents
End With
End Sub

Private Sub CommandButton1_Click()
'....'
If pass = "123" Then
Sheet1.Range("D6:F11").ClearContents
Sheet2.Range("A5:R40").ClearContents
ClearRange Sheet3
ClearRange Sheet5
ClearRange Sheet7
ClearRange Sheet9
Else
'....'
End Sub
 
Upvote 0
DavidChau đã viết:
Rất cảm ơn YOU, code chạy rất tốt. Xin YOU dành chút thì giờ giải thích dùm đoạn code để em út học hỏi kinh nghiệm. Rất mong sự giải thích của YOU. Cảm ơn nhiều lắm.
Nhấp chuột vào đây để mở rộng...

Chú bé phèn được yêu oan uổng rồi. Phê nhỉ.
 
Upvote 0
Tình Hình là mình đang Viết 1 khúc code tổng hợp dữ liệu từ nhiều Sheet khác nhau cộng dồn lại một Mảng xong chia 3 phần gán kết quả xuống Sheet TongHop ...Mà chưa làm được Mong các Bạn trợ giúp

Nó sẻ phát Sinh 3 trường Hợp như sau:

1/ Trên 3 Sheet AABB, AAAA, ABAB có dữ liệu 2 cột và 10 dòng như nhau thì nó sẻ gán kết quả xuống sheet TongHop 3 Phần như nhau như Sheet KetQuaMongMuon

2/ Nếu 3 Sheet cộng lại có 32 dòng thì có 1 phần là 10 dòng còn lại 2 phần kia là 11 dòng

3/ Nếu 3 Sheet Cộng lại Có 31 dòng thì có 2 phần là 10 dòng còn lại 1 phần kia là 11 dòng

4/ Lưu ý dữ liệu các Sheet cần tổng hợp luôn luôn biến động không cố định ...

Mình có viết code sau vì sẻ có nhiều Sheet khác nữa nên ko sử dụng For Each mà sử dụng 1 Array để duyệt Sheet .... code chạy tốt nhưng chưa hình dung ra cách chia kết quả gán xuống sheet như nêu trên Mong các Bạn Trợ giúp ......

Xin cảm ơn
Mã: 
Public Sub TongHop()
    Application.ScreenUpdating = False
        Dim Sh As Worksheet
        Dim Arr(), Res(1 To 65536, 1 To 2), SheetName(), Sht()
        Dim i As Long, k As Long, x As Long
        Set Sh = ThisWorkbook.Worksheets(Sheet4.Name)
        SheetName = Array(Sheet1.Name, Sheet2.Name, Sheet3.Name)
        Call GetSheetName(SheetName, Sht())
        For x = 1 To UBound(Sht)
            With Sheets(Sht(x))
                Arr = .Range("A1", .[A65536].End(3).Resize(, 2)).Value
            End With
            For i = 1 To UBound(Arr)
                If Arr(i, 1) <> Empty Then
                    k = k + 1
                    Res(k, 1) = Arr(i, 1)
                    Res(k, 2) = Arr(i, 2)
                End If
            Next
        Next
        With Sh.Range("A1")
            .Resize(k * 5, 2).ClearContents
            .Resize(k, 2) = Res
        End With
        Call ChangeFont(Sh, Range("A1"))
        Call FixColumnsRows(Sh)
    Application.ScreenUpdating = True
End Sub
 

File đính kèm

Lần chỉnh sửa cuối:
Upvote 0
kieu manh đã viết:
Tình Hình là mình đang Viết 1 khúc code tổng hợp dữ liệu từ nhiều Sheet khác nhau cộng dồn lại một Mảng xong chia 3 phần gán kết quả xuống Sheet TongHop ...Mà chưa làm được Mong các Bạn trợ giúp

Nó sẻ phát Sinh 3 trường Hợp như sau:

1/ Trên 3 Sheet AABB, AAAA, ABAB có dữ liệu 2 cột và 10 dòng như nhau thì nó sẻ gán kết quả xuống sheet TongHop 3 Phần như nhau như Sheet KetQuaMongMuon

2/ Nếu 3 Sheet cộng lại có 32 dòng thì có 1 phần là 10 dòng còn lại 2 phần kia là 11 dòng

3/ Nếu 3 Sheet Cộng lại Có 31 dòng thì có 2 phần là 10 dòng còn lại 1 phần kia là 11 dòng

4/ Lưu ý dữ liệu các Sheet cần tổng hợp luôn luôn biến động không cố định ...

Mình có viết code sau vì sẻ có nhiều Sheet khác nữa nên ko sử dụng For Each mà sử dụng 1 Array để duyệt Sheet .... code chạy tốt nhưng chưa hình dung ra cách chia kết quả gán xuống sheet như nêu trên Mong các Bạn Trợ giúp ......

Xin cảm ơn
Mã: 
Public Sub TongHop()
    Application.ScreenUpdating = False
        Dim Sh As Worksheet
        Dim Arr(), Res(1 To 65536, 1 To 2), SheetName(), Sht()
        Dim i As Long, k As Long, x As Long
        Set Sh = ThisWorkbook.Worksheets(Sheet4.Name)
        SheetName = Array(Sheet1.Name, Sheet2.Name, Sheet3.Name)
        Call GetSheetName(SheetName, Sht())
        For x = 1 To UBound(Sht)
            With Sheets(Sht(x))
                Arr = .Range("A1", .[A65536].End(3).Resize(, 2)).Value
            End With
            For i = 1 To UBound(Arr)
                If Arr(i, 1) <> Empty Then
                    k = k + 1
                    Res(k, 1) = Arr(i, 1)
                    Res(k, 2) = Arr(i, 2)
                End If
            Next
        Next
        With Sh.Range("A1")
            .Resize(k * 5, 2).ClearContents
            .Resize(k, 2) = Res
        End With
        Call ChangeFont(Sh, Range("A1"))
        Call FixColumnsRows(Sh)
    Application.ScreenUpdating = True
End Sub
Nhấp chuột vào đây để mở rộng...
Không biết có phải ý bạn như dưới đây hay không?

Có n phần tử, chia cho k, kết quả T là số nguyên sao cho (T1+T2+.....+Tk) = n

Nếu hiểu đúng thì ý tưởng cua mình như sau:

m= Mod(n, k) là tập số từ 0 -> k+1

m = 0 => Số phần tử mỗi cột T1 = T2 =...=Tk = n/k
m = 1 => Số phần tử mỗi cột T1 = T2 =...=T(k-m) = Int(n/k), Tk = Int(n/k) + 1
m = 2 => Số phần tử mỗi cột T1 = T2=...=T(k-m)= Int(n/k), T(k-2) = T(k-1) = T(k) = Int(n/k)+1
m = i => Số phần tử mỗi cột T1 = T2=...=T(k-i) = Int(n/k), T(k-i) = T(k-i-1) ....=T(k) = Int(n/k)+1

Code chia sẽ là
Mã: 
Sub ChiaCot()
Dim n As Long
Dim k As Long
Dim m As Long
Dim MinSoPhanTuTrongCot As Long

n = 100
k = 6

MinSoPhanTuTrongCot = Int(n / k)
m = n - Int(n / k) * k

For i = 1 To k - m
    Cells(1, i) = MinSoPhanTuTrongCot
Next

For i = k - m + 1 To k
    Cells(1, i) = MinSoPhanTuTrongCot + 1
Next

End Sub
 
Upvote 0
dhn46 đã viết:
Không biết có phải ý bạn như dưới đây hay không?

Có n phần tử, chia cho k, kết quả T là số nguyên sao cho (T1+T2+.....+Tk) = n

Nếu hiểu đúng thì ý tưởng cua mình như sau:

m= Mod(n, k) là tập số từ 0 -> k+1

m = 0 => Số phần tử mỗi cột T1 = T2 =...=Tk = n/k
m = 1 => Số phần tử mỗi cột T1 = T2 =...=T(k-m) = Int(n/k), Tk = Int(n/k) + 1
m = 2 => Số phần tử mỗi cột T1 = T2=...=T(k-m)= Int(n/k), T(k-2) = T(k-1) = T(k) = Int(n/k)+1
m = i => Số phần tử mỗi cột T1 = T2=...=T(k-i) = Int(n/k), T(k-i) = T(k-i-1) ....=T(k) = Int(n/k)+1

Code chia sẽ là
Mã: 
Sub ChiaCot()
Dim n As Long
Dim k As Long
Dim m As Long
Dim MinSoPhanTuTrongCot As Long

n = 100
k = 6

MinSoPhanTuTrongCot = Int(n / k)
m = n - Int(n / k) * k

For i = 1 To k - m
    Cells(1, i) = MinSoPhanTuTrongCot
Next

For i = k - m + 1 To k
    Cells(1, i) = MinSoPhanTuTrongCot + 1
Next

End Sub
Nhấp chuột vào đây để mở rộng...
Mạnh thuộc thành phần tự mò tự học coi mà ko hiểu gì hết ... Nếu được Bạn viết dùm 1 code mẫu hoàn chỉnh Mạnh coi là hiểu à
Xin cảm ơn
 
Upvote 0
kieu manh đã viết:
Tình Hình là mình đang Viết 1 khúc code tổng hợp dữ liệu từ nhiều Sheet khác nhau cộng dồn lại một Mảng xong chia 3 phần gán kết quả xuống Sheet TongHop ...Mà chưa làm được Mong các Bạn trợ giúp

Nó sẻ phát Sinh 3 trường Hợp như sau:

1/ Trên 3 Sheet AABB, AAAA, ABAB có dữ liệu 2 cột và 10 dòng như nhau thì nó sẻ gán kết quả xuống sheet TongHop 3 Phần như nhau như Sheet KetQuaMongMuon

2/ Nếu 3 Sheet cộng lại có 32 dòng thì có 1 phần là 10 dòng còn lại 2 phần kia là 11 dòng

3/ Nếu 3 Sheet Cộng lại Có 31 dòng thì có 2 phần là 10 dòng còn lại 1 phần kia là 11 dòng

4/ Lưu ý dữ liệu các Sheet cần tổng hợp luôn luôn biến động không cố định ...

Mình có viết code sau vì sẻ có nhiều Sheet khác nữa nên ko sử dụng For Each mà sử dụng 1 Array để duyệt Sheet .... code chạy tốt nhưng chưa hình dung ra cách chia kết quả gán xuống sheet như nêu trên Mong các Bạn Trợ giúp ......

Xin cảm ơn
Mã: 
Public Sub TongHop()
    Application.ScreenUpdating = False
        Dim Sh As Worksheet
        Dim Arr(), Res(1 To 65536, 1 To 2), SheetName(), Sht()
        Dim i As Long, k As Long, x As Long
        Set Sh = ThisWorkbook.Worksheets(Sheet4.Name)
        SheetName = Array(Sheet1.Name, Sheet2.Name, Sheet3.Name)
        Call GetSheetName(SheetName, Sht())
        For x = 1 To UBound(Sht)
            With Sheets(Sht(x))
                Arr = .Range("A1", .[A65536].End(3).Resize(, 2)).Value
            End With
            For i = 1 To UBound(Arr)
                If Arr(i, 1) <> Empty Then
                    k = k + 1
                    Res(k, 1) = Arr(i, 1)
                    Res(k, 2) = Arr(i, 2)
                End If
            Next
        Next
        With Sh.Range("A1")
            .Resize(k * 5, 2).ClearContents
            .Resize(k, 2) = Res
        End With
        Call ChangeFont(Sh, Range("A1"))
        Call FixColumnsRows(Sh)
    Application.ScreenUpdating = True
End Sub
Nhấp chuột vào đây để mở rộng...
Thử code sau
Mã: 
Public Sub TongHop()
    Application.ScreenUpdating = False
        Dim Sh As Worksheet
        Dim Arr(), Res(1 To 65536, 1 To 2), SheetName(), Sht()
        Dim i As Long, k As Long, x As Long, sRow, m, n, j, ik
        Set Sh = ThisWorkbook.Worksheets(Sheet4.Name)
        SheetName = Array(Sheet1.Name, Sheet2.Name, Sheet3.Name)
        Call GetSheetName(SheetName, Sht())
        For x = 1 To UBound(Sht)
            With Sheets(Sht(x))
                Arr = .Range("A1", .[A65536].End(3).Resize(, 2)).Value
            End With
            For i = 1 To UBound(Arr)
                If Arr(i, 1) <> Empty Then
                    k = k + 1
                    Res(k, 1) = Arr(i, 1)
                    Res(k, 2) = Arr(i, 2)
                End If
            Next
        Next
        m = Application.RoundUp(k / 3, 0)
        n = 2 - ((k - 1) Mod 3)
        ReDim Arr(1 To m, 1 To 6)
        For j = 1 To 3
          If j <= n Then sRow = m - 1 Else sRow = m
          For i = 1 To sRow
            ik = ik + 1
            Arr(i, j * 2 - 1) = Res(ik, 1)
            Arr(i, j * 2) = Res(ik, 2)
          Next i
        Next j
        With Sh.Range("A1")
            .Resize(k * 5, 6).ClearContents
            .Resize(m, 6) = Arr
        End With
        Call ChangeFont(Sh, Range("A1"))
        Call FixColumnsRows(Sh)
    Application.ScreenUpdating = True
End Sub
 
Upvote 0
HieuCD đã viết:
Thử code sau
Mã: 
Public Sub TongHop()
    Application.ScreenUpdating = False
        Dim Sh As Worksheet
        Dim Arr(), Res(1 To 65536, 1 To 2), SheetName(), Sht()
        Dim i As Long, k As Long, x As Long, sRow, m, n, j, ik
        Set Sh = ThisWorkbook.Worksheets(Sheet4.Name)
        SheetName = Array(Sheet1.Name, Sheet2.Name, Sheet3.Name)
        Call GetSheetName(SheetName, Sht())
        For x = 1 To UBound(Sht)
            With Sheets(Sht(x))
                Arr = .Range("A1", .[A65536].End(3).Resize(, 2)).Value
            End With
            For i = 1 To UBound(Arr)
                If Arr(i, 1) <> Empty Then
                    k = k + 1
                    Res(k, 1) = Arr(i, 1)
                    Res(k, 2) = Arr(i, 2)
                End If
            Next
        Next
        m = Application.RoundUp(k / 3, 0)
        n = 2 - ((k - 1) Mod 3)
        ReDim Arr(1 To m, 1 To 6)
        For j = 1 To 3
          If j <= n Then sRow = m - 1 Else sRow = m
          For i = 1 To sRow
            ik = ik + 1
            Arr(i, j * 2 - 1) = Res(ik, 1)
            Arr(i, j * 2) = Res(ik, 2)
          Next i
        Next j
        With Sh.Range("A1")
            .Resize(k * 5, 6).ClearContents
            .Resize(m, 6) = Arr
        End With
        Call ChangeFont(Sh, Range("A1"))
        Call FixColumnsRows(Sh)
    Application.ScreenUpdating = True
End Sub
Nhấp chuột vào đây để mở rộng...
Tuyệt Vời .........Cảm ơn Bạn
Mình Muốn mở rộng học thêm 1 chút ....

Ngoài cách này còn cách nào viết khác nữa ko .... Ý mình là cùng một sự việc đó ta có thể viết được mấy cách .... Tính Mình hay thích nghiên cứu và khai thác vấn đề ở nhiều khía cạnh khác nhau đó mà .... Mục đích để Học thêm
 
Upvote 0
kieu manh đã viết:
Mạnh thuộc thành phần tự mò tự học coi mà ko hiểu gì hết ... Nếu được Bạn viết dùm 1 code mẫu hoàn chỉnh Mạnh coi là hiểu à
Xin cảm ơn
Nhấp chuột vào đây để mở rộng...
Dhn46 múa rìu qua mắt thợ rồi bạn
Mã: 
Public Sub TongHop1()
    Application.ScreenUpdating = False
        Dim Sh As Worksheet
        Dim Arr(), Res(1 To 65536, 1 To 2), SheetName(), Sht()
        Dim i As Long, k As Long, x As Long
        Set Sh = ThisWorkbook.Worksheets(Sheet4.Name)
        SheetName = Array(Sheet1.Name, Sheet2.Name, Sheet3.Name)
        Call GetSheetName(SheetName, Sht())
        '------------------------------------
        Dim n As Long
        Dim k1 As Long
        Dim m As Long
        Dim r As Long
        Dim MinSoPhanTuTrongCot As Long
        '------------------------------------
        For x = 1 To UBound(Sht)
            With Sheets(Sht(x))
                Arr = .Range("A1", .[A65536].End(3).Resize(, 2)).Value
            End With
            For i = 1 To UBound(Arr)
                If Arr(i, 1) <> Empty Then
                    k = k + 1
                    Res(k, 1) = Arr(i, 1)
                    Res(k, 2) = Arr(i, 2)
                End If
            Next
        Next
        With Sh.Range("A1")
            .Resize(k * 5, 2).ClearContents
            .Resize(k, 2) = Res
        End With
        Call ChangeFont(Sh, Range("A1"))
        Call FixColumnsRows(Sh)
        '--------------------------------------
        With Sheets("TongHop")
            Arr = .Range("A1", .[A65536].End(3).Resize(, 2)).Value
        End With
        n = UBound(Arr, 1)
        k1 = 3
        MinSoPhanTuTrongCot = Int(n / k1)
        m = n - Int(n / k1) * k1
        With Sheets("KetQuaMongMuon")
        .UsedRange.ClearContents
        For i = 1 To k1 - m
            For r = 1 To MinSoPhanTuTrongCot
                .Cells(r, 1 + (i - 1) * 2) = Arr(r + (i - 1) * MinSoPhanTuTrongCot, 1)
                .Cells(r, 2 + (i - 1) * 2) = Arr(r + (i - 1) * MinSoPhanTuTrongCot, 2)
            Next
        Next
        For i = k1 - m + 1 To k1
            For r = 1 To MinSoPhanTuTrongCot + 1
                .Cells(r, 1 + (i - 1) * 2) = Arr(r + (i - 1) * MinSoPhanTuTrongCot, 1)
                .Cells(r, 2 + (i - 1) * 2) = Arr(r + (i - 1) * MinSoPhanTuTrongCot, 2)
            Next
        Next
        End With
        '----------------------------------------
    Application.ScreenUpdating = True
End Sub
 
Upvote 0
kieu manh đã viết:
cách nào viết khác nữa
Nhấp chuột vào đây để mở rộng...
Anh Mạnh thử đoạn sau xem ... :p
PHP: 
Public Sub TongHop()
    Application.ScreenUpdating = False
        Dim Sh As Worksheet
        Dim Arr(), Res(), SheetName(), Sht(), Result
        Dim i As Long, k As Long, x As Long
        Set Sh = ThisWorkbook.Worksheets(Sheet4.Name)
        SheetName = Array(Sheet1.Name, Sheet2.Name, Sheet3.Name)
        Call GetSheetName(SheetName, Sht())
        For x = 1 To UBound(Sht)
            With Sheets(Sht(x))
                Arr = .Range("A1", .[A65536].End(3).Resize(, 2)).Value
            End With
            For i = 1 To UBound(Arr)
                If Arr(i, 1) <> Empty Then
                    k = k + 1
                    ReDim Preserve Res(1 To 2, 1 To k)
                    Res(1, k) = Arr(i, 1)
                    Res(2, k) = Arr(i, 2)
                End If
            Next
        Next
        If k Then
            Result = SplitArr2D(TransposeArr2D(Res))
            With Sh.Range("A1")
                .Resize(65536, 6).ClearContents
                .Resize(UBound(Result, 1), 6) = Result
            End With
        End If
        'Call ChangeFont(Sh, Range("A1"))
        'Call FixColumnsRows(Sh)
    Application.ScreenUpdating = True
End Sub
'---------------'
Private Function TransposeArr2D(ByVal arSrc)
    Dim Arr, Result(), maxC As Long, j As Long, k As Long
    Arr = arSrc
    maxC = UBound(Arr, 1)
    ReDim Result(1 To UBound(Arr, 2), 1 To maxC)
    For k = 1 To UBound(Arr, 2)
        For j = 1 To maxC
            Result(k, j) = Arr(j, k)
        Next j
    Next k
    TransposeArr2D = Result
End Function
'---------------'
Private Function SplitArr2D(ByVal arSrc)
    Rem == chia mang 2 chieu thanh 3 phan
    If IsArray(arSrc) = False Then Exit Function
    Dim Arr, Result(), maxR As Long, N As Long, d As Long
    Dim i As Long, j As Long, k As Long
    Arr = arSrc
    maxR = UBound(Arr, 1)
    N = WorksheetFunction.Quotient(maxR, 3)
    d = maxR Mod 3
    ReDim Result(1 To N + 1, 1 To 6)
    j = 1: k = 1
    For i = 1 To maxR
        Select Case d
            Case 0, 1
                If j = N + 1 And i < maxR Then j = 1: k = k + 2
                Result(j, k) = Arr(i, 1)
                Result(j, k + 1) = Arr(i, 2)
                j = j + 1
            Case 2
                Result(j, k) = Arr(i, 1)
                Result(j, k + 1) = Arr(i, 2)
                j = j + 1
                If i = N Then j = 1: k = k + 2
                If i = 2 * N + 1 Then j = 1: k = k + 2
        End Select
    Next i
    SplitArr2D = Result
End Function
 
Lần chỉnh sửa cuối:
Upvote 0
befaint đã viết:
Anh Mạnh thử đoạn sau xem ... :p
PHP: 
Public Sub TongHop()
    Application.ScreenUpdating = False
        Dim Sh As Worksheet
        Dim Arr(), Res(), SheetName(), Sht(), Result
        Dim i As Long, k As Long, x As Long
        Set Sh = ThisWorkbook.Worksheets(Sheet4.Name)
        SheetName = Array(Sheet1.Name, Sheet2.Name, Sheet3.Name)
        Call GetSheetName(SheetName, Sht())
        For x = 1 To UBound(Sht)
            With Sheets(Sht(x))
                Arr = .Range("A1", .[A65536].End(3).Resize(, 2)).Value
            End With
            For i = 1 To UBound(Arr)
                If Arr(i, 1) <> Empty Then
                    k = k + 1
                    ReDim Preserve Res(1 To 2, 1 To k)
                    Res(1, k) = Arr(i, 1)
                    Res(2, k) = Arr(i, 2)
                End If
            Next
        Next
        If k Then
            Result = SplitArr2D(TransposeArr2D(Res))
            With Sh.Range("A1")
                .Resize(65536, 6).ClearContents
                .Resize(UBound(Result, 1), 6) = Result
            End With
        End If
        'Call ChangeFont(Sh, Range("A1"))
        'Call FixColumnsRows(Sh)
    Application.ScreenUpdating = True
End Sub
'---------------'
Private Function TransposeArr2D(ByVal arSrc)
    Dim Arr, Result(), maxC As Long, j As Long, k As Long
    Arr = arSrc
    maxC = UBound(Arr, 1)
    ReDim Result(1 To UBound(Arr, 2), 1 To maxC)
    For k = 1 To UBound(Arr, 2)
        For j = 1 To maxC
            Result(k, j) = Arr(j, k)
        Next j
    Next k
    TransposeArr2D = Result
End Function
'---------------'
Private Function SplitArr2D(ByVal arSrc)
    Rem == chia mang 2 chieu thanh 3 phan
    If IsArray(arSrc) = False Then Exit Function
    Dim Arr, Result(), maxR As Long, N As Long, d As Long
    Dim i As Long, j As Long, k As Long
    Arr = arSrc
    maxR = UBound(Arr, 1)
    N = WorksheetFunction.Quotient(maxR, 3)
    d = maxR Mod 3
    ReDim Result(1 To N + 1, 1 To 6)
    j = 1: k = 1
    For i = 1 To UBound(Arr, 1)
        Select Case d
            Case 0, 1
                Result(j, k) = Arr(i, 1)
                Result(j, k + 1) = Arr(i, 2)
                j = j + 1
                If i Mod N = 0 Then j = 1: k = k + 2
            Case 2
                Result(j, k) = Arr(i, 1)
                Result(j, k + 1) = Arr(i, 2)
                j = j + 1
                If i = N Then j = 1: k = k + 2
                If i = 2 * N + 1 Then j = 1: k = k + 2
        End Select
    Next i
    SplitArr2D = Result
End Function
Nhấp chuột vào đây để mở rộng...
Cảm ơn các Bạn ...
Vậy là cùng 1 vấn đề Mạnh học được 3 cách xử lý khác nhau

Cách của @befaint sao Mạnh chạy thấy LỗiCapture.PNG
 
Upvote 0
Góp thêm một cách
Mã: 
Public Sub TongHop()
    Application.ScreenUpdating = False
        Dim Sh As Worksheet
        Dim Arr(), Res(1 To 65536, 1 To 6), SheetName(), Sht()
        Dim i As Long, k As Long, x As Long, sRow, m, n, j, sk, S
        Set Sh = ThisWorkbook.Worksheets(Sheet4.Name)
        SheetName = Array(Sheet1.Name, Sheet2.Name, Sheet3.Name)
        Call GetSheetName(SheetName, Sht())
        S = UBound(Sht)
        ReDim Sarr(1 To S)
        For x = 1 To S
            sk = sk + Sheets(Sht(x)).[A65536].End(3).Row
        Next x
        m = Application.RoundUp(sk / S, 0)
        n = S - 1 - ((sk - 1) Mod S)
        For x = 1 To S
            With Sheets(Sht(x))
              Arr = .Range("A1", .[A65536].End(3).Resize(, 2)).Value
            End With
            For i = 1 To UBound(Arr)
                If Arr(i, 1) <> Empty Then
                    If k = sRow Or k = 0 Then
                      k = 0
                      j = j + 1
                      If j <= n Then sRow = m - 1 Else sRow = m
                    End If
                    k = k + 1
                    Res(k, j * 2 - 1) = Arr(i, 1)
                    Res(k, j * 2) = Arr(i, 2)
                End If
            Next
        Next
        With Sh.Range("A1")
            .Resize(.Offset(65500, S * 2).End(xlUp).Row, S * 2).ClearContents
            .Resize(m, S * 2) = Res
        End With
        Call ChangeFont(Sh, Range("A1"))
        Call FixColumnsRows(Sh)
    Application.ScreenUpdating = True
End Sub
Chúc các bạn cuối tuần vui
 
Upvote 0
HieuCD đã viết:
Góp thêm một cách
Mã: 
Public Sub TongHop()
    Application.ScreenUpdating = False
        Dim Sh As Worksheet
        Dim Arr(), Res(1 To 65536, 1 To 6), SheetName(), Sht()
        Dim i As Long, k As Long, x As Long, sRow, m, n, j, sk, S
        Set Sh = ThisWorkbook.Worksheets(Sheet4.Name)
        SheetName = Array(Sheet1.Name, Sheet2.Name, Sheet3.Name)
        Call GetSheetName(SheetName, Sht())
        S = UBound(Sht)
        ReDim Sarr(1 To S)
        For x = 1 To S
            sk = sk + Sheets(Sht(x)).[A65536].End(3).Row
        Next x
        m = Application.RoundUp(sk / S, 0)
        n = S - 1 - ((sk - 1) Mod S)
        For x = 1 To S
            With Sheets(Sht(x))
              Arr = .Range("A1", .[A65536].End(3).Resize(, 2)).Value
            End With
            For i = 1 To UBound(Arr)
                If Arr(i, 1) <> Empty Then
                    If k = sRow Or k = 0 Then
                      k = 0
                      j = j + 1
                      If j <= n Then sRow = m - 1 Else sRow = m
                    End If
                    k = k + 1
                    Res(k, j * 2 - 1) = Arr(i, 1)
                    Res(k, j * 2) = Arr(i, 2)
                End If
            Next
        Next
        With Sh.Range("A1")
            .Resize(.Offset(65500, S * 2).End(xlUp).Row, S * 2).ClearContents
            .Resize(m, S * 2) = Res
        End With
        Call ChangeFont(Sh, Range("A1"))
        Call FixColumnsRows(Sh)
    Application.ScreenUpdating = True
End Sub
Chúc các bạn cuối tuần vui
Nhấp chuột vào đây để mở rộng...
Quả thực chạy cộng , trừ, nhân và Chia trực tiếp trên Mảng luôn tốc độ rất nhanh

Cách này bỏ 1 vòng For rất hay nhưng lấy S = UBound(Sht) = 3 sheet để chia 3 cột ... nếu ta thêm 1 Sheet là CCCC nữa là lỗi code phải sửa lại ở dưới ... còn cách Bạn viết Lần 1 ta muốn thêm bao nhiêu Sheet OK hết ...
Cảm ơn Bạn
 
Lần chỉnh sửa cuối:
Upvote 0
kieu manh đã viết:
Cách của @befaint sao Mạnh chạy thấy Lỗi
Nhấp chuột vào đây để mở rộng...
Em sửa lại chỗ lỗi. Anh kiểm tra thử nhé.
PHP: 
Private Function SplitArr2D(ByVal arSrc)
    Rem == chia mang 2 chieu thanh 3 phan
    If IsArray(arSrc) = False Then Exit Function
    Dim Arr, Result(), maxR As Long, N As Long, d As Long
    Dim i As Long, j As Long, k As Long
    Arr = arSrc
    maxR = UBound(Arr, 1)
    N = WorksheetFunction.Quotient(maxR, 3)
    d = maxR Mod 3
    ReDim Result(1 To N + 1, 1 To 6)
    j = 1: k = 1
    For i = 1 To maxR
        Select Case d
            Case 0, 1
                If j = N + 1 And i < maxR Then j = 1: k = k + 2
                Result(j, k) = Arr(i, 1)
                Result(j, k + 1) = Arr(i, 2)
                j = j + 1
            Case 2
                Result(j, k) = Arr(i, 1)
                Result(j, k + 1) = Arr(i, 2)
                j = j + 1
                If i = N Then j = 1: k = k + 2
                If i = 2 * N + 1 Then j = 1: k = k + 2
        End Select
    Next i
    SplitArr2D = Result
End Function
 
Upvote 0
befaint đã viết:
Em sửa lại chỗ lỗi. Anh kiểm tra thử nhé.
PHP: 
Private Function SplitArr2D(ByVal arSrc)
    Rem == chia mang 2 chieu thanh 3 phan
    If IsArray(arSrc) = False Then Exit Function
    Dim Arr, Result(), maxR As Long, N As Long, d As Long
    Dim i As Long, j As Long, k As Long
    Arr = arSrc
    maxR = UBound(Arr, 1)
    N = WorksheetFunction.Quotient(maxR, 3)
    d = maxR Mod 3
    ReDim Result(1 To N + 1, 1 To 6)
    j = 1: k = 1
    For i = 1 To maxR
        Select Case d
            Case 0, 1
                If j = N + 1 And i < maxR Then j = 1: k = k + 2
                Result(j, k) = Arr(i, 1)
                Result(j, k + 1) = Arr(i, 2)
                j = j + 1
            Case 2
                Result(j, k) = Arr(i, 1)
                Result(j, k + 1) = Arr(i, 2)
                j = j + 1
                If i = N Then j = 1: k = k + 2
                If i = 2 * N + 1 Then j = 1: k = k + 2
        End Select
    Next i
    SplitArr2D = Result
End Function
Nhấp chuột vào đây để mở rộng...
Chạy tốt Mọi .......... Cái cho hết lên mãng tính nó chạy nhanh hơn trên Cells
 
Upvote 0
Các anh giúp em lập hàm này với ạ: Dò tìm giá trị ô I12 từ một trong 2 sheet vs các điều kiện sau:
- Nếu I8 là "Chuyển khoản" thì tìm trong Sheet "CHUYEN KHOAN", Nếu I8 là "Tiền mặt" dò trong Sheet "TIEN MAT"
- Khi dò tìm giá trị tại I8 ở mỗi sheet lại thỏa mãn điều kiện I8 là giá trị tại ô là giao của hàng và cột được tìm như sau:
+ Hàng là hàng có chứa "MÃ ĐVQHNS" tại ô I9
+ Cột là cột chứa số tháng có giá trị = I11 - 1
E cảm ơn các anh ạ
 

File đính kèm

Upvote 0
hjx hjx ..... e nhầm anh ơi, code VBA ạ. Em nhầm. Sry anhhhh. Anh giúp em cái. E sửa bài nha
Nhấp chuột vào đây để mở rộng...
Bạn fải trả giá cho sự nhầm lẫn của mình đi chứ; bằng 1 trong các cách sau:

(1) Cứ để hàm í mà xài, dù nắng mưa hay chậm nhanh gì đó cũng đán!
(2) Tự tìm cách mà viết thành 1 macro sự kiện gắn liền với [I11], với sự tham khảo của hàm trên
(3) Lập bài đăng mới hay chờ ai đi ngang có lòng hảo tâm thực hiện macro mới cho bạn!

Chúc ngày cuối tuần vui vẻ!-.,\;
 
Upvote 0
Nhờ mấy anh chỉ em cái chổ khai báo textbox như thế nào để lấy giá trị như hàm dưới
PHP: 
Private Sub CommandButton318_Click() '---------ver2
Dim MyRan As Range
Dim Arr As Variant
Dim Irow As Integer, Icl As Integer, k As Integer
Set MyRan = Range("C45:H65")
For Irow = 0 To MyRan.Rows.Count
Debug.Print Irow
For Icl = 1 To 6
k = k
If Worksheets("1").Range("B45").Offset(Irow, Icl).Interior.ColorIndex = -4142 Then
Debug.Print Worksheets("1").Range("B45").Offset(Irow, Icl).Value
TextBox(k + 1) = Worksheets("1").Range("B45").Offset(Irow, Icl).Value
' Em khong biết làm thế nào để khai báo cái textbox làm sao???
Debug.Print "K:" & k
End If
 Next
  Next Irow
       End Sub
End Sub
 
Upvote 0
SA_DQ đã viết:
Bạn fải trả giá cho sự nhầm lẫn của mình đi chứ; bằng 1 trong các cách sau:

(1) Cứ để hàm í mà xài, dù nắng mưa hay chậm nhanh gì đó cũng đán!
(2) Tự tìm cách mà viết thành 1 macro sự kiện gắn liền với [I11], với sự tham khảo của hàm trên
(3) Lập bài đăng mới hay chờ ai đi ngang có lòng hảo tâm thực hiện macro mới cho bạn!

Chúc ngày cuối tuần vui vẻ!-.,\;
Nhấp chuột vào đây để mở rộng...
cái giá hơi bị nặng, em sẽ thử. k đc nhờ huynh tiếp nhá :3
 
Upvote 0
Tôi có cái code như này:
Mã: 
Sub Chay()
Dim Min, Max As Date
Dim dem As Integer
Dim Rng As Range
   Set Rng = Sheet1.[B2:B3]
    Min = Application.Min(Rng)
    Max = Application.Max(Rng)
With Sheet2
    .Range("B1:B10000").ClearContents
     If Min > 42004 And Max < 44196 Then
       For dem = 0 To Max - Min
   .Cells(1 + dem, 2) = Min + dem
    Next
End If
End With
Application.ScreenUpdating = True
End Sub
Khi chạy khoảng Min đến Max mà dữ liệu khoảng trên 1000 dòng thì hơi bị chậm, mong anh chị em có cách gì giúp tăng tốc không ạ. Xin cảm ơn
 
Upvote 0
Sub tinh_so()
Dim Ttruoc As Long, Tnay As Long, tang As Long, giam As Long
Set Ttruoc = ThisWorkbook.Worksheets(1).I12
Set Tnay = ThisWorkbook.Worksheets(1).I13
Set tang = ThisWorkbook.Worksheets(1).I14
Set giam = ThisWorkbook.Worksheets(1).I15
MsgBox "So chenh lech thang nay so voi thang truoc la" & Ttruoc - Tnay + tang - giam
End Sub
Các bác giúp hộ e xem cái này sai ở đâu ạ
 
Upvote 0
Miccpro đã viết:
tăng tốc
Nhấp chuột vào đây để mở rộng...
Tăng tốc thì mình đọc bài sau xem...
PHP: 
If Min > 42004 And Max < 44196 Then
    If Min <= Max Then
      Min = CLng(Min): Max = CLng(Max)
        Dim a(), i As Long
        ReDim a(1 To Max - Min + 1, 1 To 1)
        For dem = Min To Max
            i = i + 1
            a(i, 1) = dem
        Next
        .Cells(1, 2).Resize(UBound(a, 1), 1) = a
    End If
End If
 
Lần chỉnh sửa cuối:
Upvote 0
befaint đã viết:
Nhấn F5 mà vàng chỗ nào thì sai chỗ đó.
Đọc bài sau xem...
Nhấp chuột vào đây để mở rộng...
em xem thì nó bảo kiểu là vba nó không hiểu code em viết ấy, em không biết sai ở đâu cả ạ.
Em viết lại như sau mà vẫn k đc:
"Option Explicit
Sub tinh_chenh_lech()
Dim Ttruoc As Long, Tnay As Long, tang As Long, giam As Long
Set Ttruoc = ThisWorkbook.Worksheets(1).I12.Value
Set Tnay = ThisWorkbook.Worksheets(1).I13.Value
Set tang = ThisWorkbook.Worksheets(1).I14.Value
Set giam = ThisWorkbook.Worksheets(1).I15.Value
MsgBox "So chenh lech thang nay so voi thang truoc la" & chenhlech
End Sub
Function chenhlech(ByVal Ttruoc, ByVal Tnay, ByVal tang, ByVal giam)
chenhlech = Ttruoc - Tnay + tang - giam
End Function"
Muc đích của e là sẽ tính ra số chênh lệch và xuất ra màn hình, số chênh lệch = tháng trước (I12)- tháng này (I13) +tăng (I14)- giảm (I15).
Anh xem chỉ em với ạ
befaint đã viết:
Nhấn F5 mà vàng chỗ nào thì sai chỗ đó.
Đọc bài sau xem...
Nhấp chuột vào đây để mở rộng...
 
Upvote 0
Hình như các câu lệnh này có vấn đề:
PHP: 
Set Ttruoc = ThisWorkbook.Worksheets(1).I12.Value
Set Tnay = ThisWorkbook.Worksheets(1).I13.Value
Set tang = ThisWorkbook.Worksheets(1).I14.Value
Set giam = ThisWorkbook.Worksheets(1).I15.Value

Các biến này (Truoc, Thay, Tang, Giam) không là các biến đối tượng sao lại xài fép gán là 'Set'?; Từ khóa này chỉ dành cho các biến đối tượng mà thôi. Như:
Mã: 
 Dim Rng as Range
Set Rng = ThisWorkbook.Worksheets("GPE").[I14]
Tang = Rng.Value

Các địa chỉ ô cần để trong ngoặt, như [I15]
Còn 1 vấn đề không quan trọng nữa, nhưng để sau
 
Upvote 0
SA_DQ đã viết:
Hình như các câu lệnh này có vấn đề:
PHP: 
Set Ttruoc = ThisWorkbook.Worksheets(1).I12.Value
Set Tnay = ThisWorkbook.Worksheets(1).I13.Value
Set tang = ThisWorkbook.Worksheets(1).I14.Value
Set giam = ThisWorkbook.Worksheets(1).I15.Value

Các biến này (Truoc, Thay, Tang, Giam) không là các biến đối tượng sao lại xài fép gán là 'Set'?; Từ khóa này chỉ dành cho các biến đối tượng mà thôi. Như:
Mã: 
 Dim Rng as Range
Set Rng = ThisWorkbook.Worksheets("GPE").[I14]
Tang = Rng.Value

Các địa chỉ ô cần để trong ngoặt, như [I15]
Còn 1 vấn đề không quan trọng nữa, nhưng để sau
Nhấp chuột vào đây để mở rộng...
mình sửa lại như sau nhưng vẫn k chạy được bạn ạ:
"Option Explicit
Sub tinh_chenh_lech()
Dim Ttruoc As Long, Tnay As Long, tang As Long, giam As Long
Ttruoc = ThisWorkbook.Worksheets(1).Range("I12").Value
Tnay = ThisWorkbook.Worksheets(1).Range("I13").Value
tang = ThisWorkbook.Worksheets(1).Range("I14").Value
giam = ThisWorkbook.Worksheets(1).Range("I15").Value
MsgBox "So chenh lech thang nay so voi thang truoc la" & chenhlech
End Sub
Function chenhlech(ByVal Ttruoc, ByVal Tnay, ByVal tang, ByVal giam) As formular
chenhlech = Ttruoc - Tnay + tang - giam
End Function"
bạn chỉ mình sai ở đâu với
 
Upvote 0
Cứ sau mỗi mệnh đề gán trị vô biến bạn hỏi xem VBA nó báo cho bạn trị trong biến đó là bao nhiêu?
Ví dụ:
Mã: 
 Giam = ThisWorkbook.Worksheets(1).Range("I15").Value
  MsgBox Giam, , "GPE.COM Xin Cho Biêt'

& nếu cần thì lấy giấy bút ra mà ghi lại lần lượt từng em nó một.
 
Upvote 0
Hoang2013 đã viết:
Cứ sau mỗi mệnh đề gán trị vô biến bạn hỏi xem VBA nó báo cho bạn trị trong biến đó là bao nhiêu?
Ví dụ:
Mã: 
 Giam = ThisWorkbook.Worksheets(1).Range("I15").Value
  MsgBox Giam, , "GPE.COM Xin Cho Biêt'

& nếu cần thì lấy giấy bút ra mà ghi lại lần lượt từng em nó một.
Nhấp chuột vào đây để mở rộng...
cảm ơn bạn, bạn xem giúp mình code đó sai ở đâu đc không ban
 
Upvote 0
acmen87 đã viết:
hjx .... vừa đọc vừa học vừa làm vừa hỏi nên gà lắm anh ạ. Anh thông cảm tí đi
Nhấp chuột vào đây để mở rộng...

Gà nó siêng năng bới đất chứ đâu có nằm chờ sung rụng.
Bạn đã làm theo lời bài #1172 chưa? Ghi được ra những kết quả thế nào? Nếu không chạy được thì báo lỗi ra sao và ở dòng nào?

Gợi ý: nếu không chạy được thì tạm xoá cái dòng Option Explicit
 
Upvote 0
Gợi í nên vô hiệu hóa dòng lệnh thôi; Ai lại kêu xóa tạm bao giờ, lỡ mất luôn thì sao.

Gợi í bạn: Có chí ít 2 cách vô hiệu hóa 1 dòng lệnh trong VBA; . . . .
 
Upvote 0
VetMini đã viết:
Gà nó siêng năng bới đất chứ đâu có nằm chờ sung rụng.
Bạn đã làm theo lời bài #1172 chưa? Ghi được ra những kết quả thế nào? Nếu không chạy được thì báo lỗi ra sao và ở dòng nào?

Gợi ý: nếu không chạy được thì tạm xoá cái dòng Option Explicit
Nhấp chuột vào đây để mở rộng...
mình thử làm theo bỏ function đi và nhập nó sẽ lần lượt báo các giá trị ở các ô tương ứng của biến đã khai. Có lẽ sai ở function. Mình không biết sai ở đâu :(. Bỏ option explicit đi cũng k được luôn bạn ạ
 
Upvote 0
Một trong những bước đầu tiên và căn bản của lập trình là "TẬP BỎ THÓI QUEN VIẾT TẮT"
Những từ m, n, k dùng để đặt tên cho các trị số nguyên. Đang đọc câu hỏi mà thấy chúng bị vướng như ăn bánh đúc gặp sợi tóc.

Cái function của bạn đượng nhiên là có vấn đề rồi. Bạn muốn có mọt cái kiểu tên là formular thì bạn phải tự viết code định nghĩa kiểu này chớ VBA đâu có cách nào hiểu giùm cho bạn.

acmen87 đã viết:
Function chenhlech(ByVal Ttruoc, ByVal Tnay, ByVal tang, ByVal giam) As formular
chenhlech = Ttruoc - Tnay + tang - giam
End Function"
Nhấp chuột vào đây để mở rộng...

Cách gọi function cũng sai luôn. Function định nghĩa là sẽ yêu cầu 4 tham mà lúc gọi thì trổng không chả nạp tham nào.
 
Upvote 0
MinhKhai đã viết:
Mong được giải đáp
Tôi có làm các checkbox để ẩn hiện các cột cho tiện (như file đính kèm).
Việc sử dụng thì không sao. Tuy nhiên khi mở file ra, cấu hình trong form không đúng với thực tế. Cụ thể là khi bấm dấu kiểm nào đó vào thì 1 số cột tương ứng bị ẩn, nếu đóng file lại và có save sau đó mở ra, cột vẫn bị ẩn mà dấu kiểm không còn.
Có cách nào lưu giữ dấu kiểm khi mở file tương ứng với khi đóng file ?
Xin cảm ơn
Nhấp chuột vào đây để mở rộng...
Không ai giúp được vấn đề này ạ ?
 
Upvote 0
@VetMini ; @SA_DQ ; @Hoang2013 cảm ơn các bác đã reply, em đã sửa được rồi. em làm function và nó cho ra kết quả rồi.
Code em làm như sau:
Function ChenhLech(Ttruoc As Long, Tnay As Long, tang As Long, giam As Long) As Long
Ttruoc = ThisWorkbook.Worksheets(1).Range("I12").Value
Tnay = ThisWorkbook.Worksheets(1).Range("I13").Value
tang = ThisWorkbook.Worksheets(1).Range("I14").Value
giam = ThisWorkbook.Worksheets(1).Range("I15").Value
ChenhLech = Ttruoc - Tnay + tang - giam
MsgBox ChenhLech, , "So chenh lech thang truoc so voi thang nay la"
End Function
Vấn đề là để chạy được cái này bên excel em sẽ phải viết công thức =chenhlech(I12;I13;I14;I15) vào một cell.
Giả dụ bjo em muốn gán nó vào cái hình oval có tên là tính biến động để sau chỉ ấn vào đó là nó ra kết quả thì làm thế nào ạ? Em mới chỉ biết gán macro thôi ạ. Các bác làm ơn chỉ em với ạ. Em cảm ơn nhiều
 
Upvote 0
Code em làm như sau:
PHP: 
Function ChenhLech(Ttruoc As Long, Tnay As Long, Tang As Long, Giam As Long) As Long
1 Ttruoc = ThisWorkbook.Worksheets(1).Range("I12").Value
 Tnay = ThisWorkbook.Worksheets(1).Range("I13").Value
 Tang = ThisWorkbook.Worksheets(1).Range("I14").Value
4 Giam = ThisWorkbook.Worksheets(1).Range("I15").Value
 ChenhLech = Ttruoc - Tnay + Tang - Giam
  MsgBox ChenhLech, , "Só Chênh lêch Tháng Truóc So Vói Tháng Này Là:"
End Function
Vấn đề là để chạy được cái này bên excel em sẽ phải viết công thức =chenhlech(I12;I13;I14;I15) vào một cell.
Nhấp chuột vào đây để mở rộng...

Bạn vô hiệu hóa 4 dòng lệnh từ 1 => 4 cũng sẽ không ảnh hưởng gì đến kết quả hàm cho mà xem!
 
Upvote 0
HYen17 đã viết:
Bạn vô hiệu hóa 4 dòng lệnh từ 1 => 4 cũng sẽ không ảnh hưởng gì đến kết quả hàm cho mà xem!
Nhấp chuột vào đây để mở rộng...
à vâng, đã thử và đúng vậy. Thế chỗ em hỏi thì sao anh? có cách nào gán đoạn công thức "=chenhlech(I12;I13;I14;I15)" vào hình kia để ấn vô thì nó thực thi không anh
 
Upvote 0
Em xin hỏi! vòng for
ô A1 giá trị = 100, làm cách nào để ô A1 chạy 100, 101..110
 
Upvote 0
befaint đã viết:
Tăng tốc thì mình đọc bài sau xem...
PHP: 
If Min > 42004 And Max < 44196 Then
    If Min <= Max Then
      Min = CLng(Min): Max = CLng(Max)
        Dim a(), i As Long
        ReDim a(1 To Max - Min + 1, 1 To 1)
        For dem = Min To Max
            i = i + 1
            a(i, 1) = dem
        Next
        .Cells(1, 2).Resize(UBound(a, 1), 1) = a
    End If
End If
Nhấp chuột vào đây để mở rộng...
Đã áp dụng được cái của bác befaint, cảm ơn bác nhiều, sau khi đọc link dẫn của bác về mảng thì có vấn đề này tôi chưa làm được . Đang chập chững mày mò mà làm mãi không được. Mong các anh chị em giúp đỡ, xin cảm ơn
 

File đính kèm

Upvote 0
Miccpro đã viết:
Đã áp dụng được cái của bác befaint, cảm ơn bác nhiều, sau khi đọc link dẫn của bác về mảng thì có vấn đề này tôi chưa làm được . Đang chập chững mày mò mà làm mãi không được. Mong các anh chị em giúp đỡ, xin cảm ơn
Nhấp chuột vào đây để mở rộng...
Bạn chạy thử Code này xem sao
PHP: 
Sub Miccpro()
    Dim Dic As Object, sArr(), dArr(1 To 65535, 1 To 2)
    Dim I As Long, J As Date, K As Long, R As Long
    Dim Rng As Range, Nmin As Date, Nmax As Date
Set Dic = CreateObject("Scripting.Dictionary")
With Sheet1
    Set Rng = .Range("B2", .Range("B65535").End(3)).Resize(, 2)
    Nmin = Application.Min(Rng): Nmax = Application.Max(Rng)
End With
sArr = Rng.Value2
For I = 1 To UBound(sArr)
    For J = sArr(I, 1) To sArr(I, 2)
        Dic.Item(J) = 1
    Next J
Next I
For I = Nmin To Nmax
    K = K + 1
    dArr(K, 1) = I
    R = Dic.Item(I)
    If R = 0 Then dArr(K, 2) = "Ngh" & ChrW$(7881)
Next I
With Sheet2
    Range("B2").Resize(K, 2) = dArr
End With
Set Dic = Nothing
End Sub
 
Lần chỉnh sửa cuối:
Upvote 0
Miccpro đã viết:
anh chị em
Nhấp chuột vào đây để mở rộng...
Mình xưng hô xã giao thì gọi là anh/ chị có được không?
Cho dù biết rõ người đối thoại với mình nhỏ tuổi hơn mình cả chục tuổi đi nữa, mình gọi là anh/ chị xem có bị thiệt miếng thịt nào không?
------
PHP: 
Sub bebe()
    Dim a(), arr(), b(), N As Long, Res(), D As Long
    Dim i As Long, k As Long
    a = Sheet1.Range("B2:C6").Value2
    b = Sheet2.Range("B2:B15").Value2
    N = UBound(b, 1)
    ReDim Res(1 To N, 1 To 1)
    For i = 1 To UBound(a, 1)
        If a(i, 1) <= a(i, 2) Then
            For D = a(i, 1) To a(i, 2)
                k = k + 1
                ReDim Preserve arr(1 To k)
                arr(k) = D
            Next D
        End If
    Next i
    For i = 1 To N
        If IsError(Application.Match(b(i, 1), arr, 0)) = True Then Res(i, 1) = "Ngh" & ChrW(7881)
    Next i
    Sheet2.Range("C2").Resize(N, 1) = Res
End Sub
 
Upvote 0
Giả dụ bjo em muốn gán nó vào cái hình oval có tên là tính biến động để sau chỉ ấn vào đó là nó ra kết quả thì làm thế nào ạ? Em mới chỉ biết gán macro thôi ạ. Các bác làm ơn chỉ em với ạ.
. . . . Thế chỗ em hỏi thì sao anh? có cách nào gán đoạn công thức "=chenhlech(I12;I13;I14;I15)" vào hình kia để ấn vô thì nó thực thi không anh
Nhấp chuột vào đây để mở rộng...
Bạn đã biết "gán" macro vô hình; Giờ thay nội dung đó lại là được;
Ví dụ
Mã: 
 Sub GPE  
  [I16].Value= ChenhLech([I12], [I13], [I14], [I15])
End Sub
 
Upvote 0
acmen87 đã viết:
@VetMini ; @SA_DQ ; @Hoang2013 cảm ơn các bác đã reply, em đã sửa được rồi. em làm function và nó cho ra kết quả rồi.
...
Giả dụ bjo em muốn gán nó vào cái hình oval có tên là tính biến động để sau chỉ ấn vào đó là nó ra kết quả thì làm thế nào ạ? Em mới chỉ biết gán macro thôi ạ. Các bác làm ơn chỉ em với ạ. Em cảm ơn nhiều
Nhấp chuột vào đây để mở rộng...

Thứ nhất, tôi không tiếp xúc theo kiểu vừa tiếng Việt vừa tiếng Anh. Nếu bạn dốt tiếng Việt thì cứ dùng tiếng Anh thuần túy, tôi đủ khả năng hầu tiếp (nhưng nếu trường hợp này mà bạn cho thấy dốt cả tiếng Anh thì tôi mạt sát ngay)

Thứ hai, tôi đã cảnh báo về vấn đề viết tắt. Tôi chỉ khuyến khích người hiếu học. Đối với tôi, người hiếu học khong có thói quen viết tắt.

(*) Chớ có bắt chước theo lời nhơn vật nọ lý luận rằng thời buổi bây giờ phải tập dùng tiếng Anh cho quen. Lý luận như vậy là ngụy biện. Nói thẳng ra đây tôi là người song ngữ, tiếng Anh tôi dùng không khác gì tiếng Việt. Nhưng trong suốt quá trình học, tôi không bao giờ lẫn lộn 2 cái vào nhau,
 
Upvote 0
VetMini đã viết:
Thứ nhất, tôi không tiếp xúc theo kiểu vừa tiếng Việt vừa tiếng Anh. Nếu bạn dốt tiếng Việt thì cứ dùng tiếng Anh thuần túy, tôi đủ khả năng hầu tiếp (nhưng nếu trường hợp này mà bạn cho thấy dốt cả tiếng Anh thì tôi mạt sát ngay)

Thứ hai, tôi đã cảnh báo về vấn đề viết tắt. Tôi chỉ khuyến khích người hiếu học. Đối với tôi, người hiếu học khong có thói quen viết tắt.

(*) Chớ có bắt chước theo lời nhơn vật nọ lý luận rằng thời buổi bây giờ phải tập dùng tiếng Anh cho quen. Lý luận như vậy là ngụy biện. Nói thẳng ra đây tôi là người song ngữ, tiếng Anh tôi dùng không khác gì tiếng Việt. Nhưng trong suốt quá trình học, tôi không bao giờ lẫn lộn 2 cái vào nhau,
Nhấp chuột vào đây để mở rộng...
Híc, cảm ơn bác góp ý. E sẽ rút kinh nghiệm
 
Lần chỉnh sửa cuối:
Upvote 0
befaint đã viết:
Mình xưng hô xã giao thì gọi là anh/ chị có được không?
Cho dù biết rõ người đối thoại với mình nhỏ tuổi hơn mình cả chục tuổi đi nữa, mình gọi là anh/ chị xem có bị thiệt miếng thịt nào không?
------
PHP: 
Sub bebe()
    Dim a(), arr(), b(), N As Long, Res(), D As Long
    Dim i As Long, k As Long
    a = Sheet1.Range("B2:C6").Value2
    b = Sheet2.Range("B2:B15").Value2
    N = UBound(b, 1)
    ReDim Res(1 To N, 1 To 1)
    For i = 1 To UBound(a, 1)
        If a(i, 1) <= a(i, 2) Then
            For D = a(i, 1) To a(i, 2)
                k = k + 1
                ReDim Preserve arr(1 To k)
                arr(k) = D
            Next D
        End If
    Next i
    For i = 1 To N
        If IsError(Application.Match(b(i, 1), arr, 0)) = True Then Res(i, 1) = "Ngh" & ChrW(7881)
    Next i
    Sheet2.Range("C2").Resize(N, 1) = Res
End Sub
Nhấp chuột vào đây để mở rộng...
Cảm ơn bác đã nhắc nhở, em sẽ rút kinh nghiệm.
Em xin hỏi bấc vấn đề này:
PHP: 
    a = Sheet1.Range("B2:C6").Value2
    b = Sheet2.Range("B2:B15").Value2
Giả sử em thay Sheet1.Range("B2:C6").Value2 thành Sheet1.Range("B2:C5000").Value2 chẳng hạn thì nó chạy rất chậm bác ạ. Có cách gì nhanh hơn không? Mong các bác giúp đỡ
 
Upvote 0
befaint đã viết:
Bạn gửi cả CỤM nó lên đây xem thì mới biết tại sao chậm...
Nhấp chuột vào đây để mở rộng...
Tức là khi em gán giá trị a khoảng rộng hơn, từ a = Sheet1.Range("B2:C6").Value2 thành a = Sheet1.Range("B2:C5000").Value2 thì code chạy tương đối chậm bác ạ,
Giả sử em thay thế này chẳng hạn
PHP: 
Sub bebe()
    Dim a(), arr(), b(), N As Long, Res(), D As Long
    Dim i As Long, k As Long
    a = Sheet1.Range("B2:C10000").Value2
    b = Sheet2.Range("B2:B65000").Value2
    N = UBound(b, 1)
    ReDim Res(1 To N, 1 To 1)
    For i = 1 To UBound(a, 1)
        If a(i, 1) <= a(i, 2) Then
            For D = a(i, 1) To a(i, 2)
                k = k + 1
                ReDim Preserve arr(1 To k)
                arr(k) = D
            Next D
        End If
    Next i
    For i = 1 To N
        If IsError(Application.Match(b(i, 1), arr, 0)) = True Then Res(i, 1) = "Ngh" & ChrW(7881)
    Next i
    Sheet2.Range("C2").Resize(N, 1) = Res
End Sub
 
Upvote 0
hpkhuong đã viết:
Dữ liệu ít -> tới nhiều thì chậm hơn là đúng rồi.
Mà với mảng có 5000 dòng mà chậm thì là vô lý.
Chậm do nhiều nguyên nhân, dữ liệu trên file bạn, format trên file bạn...: có biết file bạn như nào đâu mà phán....
Nhấp chuột vào đây để mở rộng...
File của em đây bác, khi em thay a = Sheet1.Range("B2:C6").Value2 thành a = Sheet1.Range("B2:C5000").Value2 chẳng hạn thì nó chạy tương đối chậm ạ
 

File đính kèm

Upvote 0
Miccpro đã viết:
File của em đây bác, khi em thay a = Sheet1.Range("B2:C6").Value2 thành a = Sheet1.Range("B2:C5000").Value2 chẳng hạn thì nó chạy tương đối chậm ạ
Nhấp chuột vào đây để mở rộng...
Trong file bạn gửi có tí dữ liệu nào tới dòng 5000 nào đâu?
Định tét code chơi cho vui hả?
b = Sheet2.Range("B2:B10000").Value2
Có biết 10,000 dòng là bao nhiêu năm không? Giả sử không bỏ sót ngày nào thì ứng với > 27 năm đó. Không biết công ty có sống thọ tới lúc đó không?

Chạy thử thấy chậm bình thường, chẳng làm sao cả.
 
Upvote 0
befaint đã viết:
Trong file bạn gửi có tí dữ liệu nào tới dòng 5000 nào đâu?
Định tét code chơi cho vui hả?
b = Sheet2.Range("B2:B10000").Value2
Có biết 10,000 dòng là bao nhiêu năm không? Giả sử không bỏ sót ngày nào thì ứng với > 27 năm đó. Không biết công ty có sống thọ tới lúc đó không?

Chạy thử thấy chậm bình thường, chẳng làm sao cả.
Nhấp chuột vào đây để mở rộng...
Vâng, thực tế là như bác nói. Em cũng có ý test ạ. Mà bác ơi; cái Value với Value2 nó khác nhau chỗ nào ạ, em tìm đọc trên mạng mà chưa hiểu lắm, bác cho em cái link được không? Cảm ơn bác
 
Upvote 0
Cái chỗ chậm là tại vì thuật toán quá tệ.
Đầu tiên, nó tuỳ theo con số k cuối cùng. Cứ mỗi lần k tăng lên 1 là lại phải Redim Preserve cái mảng.
Kế đó, là cái vòng lặp 1 tới N (N = 65000). Bên trong vòng lặp này gọi hàm Match với tham số thứ 3 là 0, dò mệt nghỉ.
Cứ tưởng tượng k = 1000, hàm match sẽ dò trung bình 1000/2 = 500 trị một lượt. 65000 lượt là ...
 
Upvote 0
VetMini đã viết:
Cái chỗ chậm là tại vì thuật toán quá tệ.
Đầu tiên, nó tuỳ theo con số k cuối cùng. Cứ mỗi lần k tăng lên 1 là lại phải Redim Preserve cái mảng.
Kế đó, là cái vòng lặp 1 tới N (N = 65000). Bên trong vòng lặp này gọi hàm Match với tham số thứ 3 là 0, dò mệt nghỉ.
Cứ tưởng tượng k = 1000, hàm match sẽ dò trung bình 1000/2 = 500 trị một lượt. 65000 lượt là ...
Nhấp chuột vào đây để mở rộng...
Bác edit dùm cái được không ạ. Xin cảm ơn
 
Upvote 0
Ok. Cám ớn bác nhé, đã sửa dược lỗi nhưng lại phát sinh lỗi không tra cứu được hàng hóa.
 
Lần chỉnh sửa cuối:
Upvote 0
E đang lập sổ quản lý đơn thư trên Ecxel, nhưng kiến thức còn hạn hẹp, không thể quản lý dữ liệu theo yêu cầu. Nhờ các bác viết giúp cho dđoạn CODE để Cell M6 có thể nhập được dữ liệu (theo list được tạo trước Validation) khi và chỉ khi Cell K6 có dữ liệu giống Cell G3 của Sheet "data". Hay nói cách khác là Ô M6 chỉ được nhận dữ liệu (từ list được tạo ra) nếu Ô K6 có dữ liệu là "CHUYỂN ĐƠN"; còn nếu Ô K6 ko phải dữ liệu là "CHUYỂN ĐƠN" thì M6 bắt buộc phải để trống và không cho nhập dữ liệu
P/S: các bác viết giúp em cho Ô M6 và K6 theo yêu cầu trên ạ, khi e cần thêm dòng thì đã có CODE thêm dòng rồi ạ
Xin cảm ơn!
 

File đính kèm

Upvote 0
tiendungnst đã viết:
E đang lập sổ quản lý đơn thư trên Ecxel, nhưng kiến thức còn hạn hẹp, không thể quản lý dữ liệu theo yêu cầu. Nhờ các bác viết giúp cho dđoạn CODE để Cell M6 có thể nhập được dữ liệu (theo list được tạo trước Validation) khi và chỉ khi Cell K6 có dữ liệu giống Cell G3 của Sheet "data". Hay nói cách khác là Ô M6 chỉ được nhận dữ liệu (từ list được tạo ra) nếu Ô K6 có dữ liệu là "CHUYỂN ĐƠN"; còn nếu Ô K6 ko phải dữ liệu là "CHUYỂN ĐƠN" thì M6 bắt buộc phải để trống và không cho nhập dữ liệu
P/S: các bác viết giúp em cho Ô M6 và K6 theo yêu cầu trên ạ, khi e cần thêm dòng thì đã có CODE thêm dòng rồi ạ
Xin cảm ơn!
Nhấp chuột vào đây để mở rộng...
Thử xem file này coi có đúng ý bạn không.
 

File đính kèm

Upvote 0
Các bác có hàm nào tham chiếu thay cho cú pháp này của em không ạ. Cái này dùng hàm của execl nhưng đưa vào vba thi báo lỗi vì vùng tham chiếu trong hàm Match báo N/A.
a = Application.WorksheetFunction.IfError(Application.WorksheetFunction.Match(Sheet4.Range("giá trị tham chiếu"), Sheet2.Range("vùng tham chiếu"), 0), 0)
 
Upvote 0
Mình có được file excel DM nhưng bị lỗi như thế này nhờ các bác giúp:
1. khi click đúp chuột trái vào cột A thì Userform hiện lên nhưng vào ô tra cứu không tra được.
2. Khi uesrform hiện lên, ta chọn 1 mã hiệu-> chọn thì ok nhưng tại cột D ( cột định mức) không trả về định dạng kiểu số nên dẫn đến công thức sai.
3. Hiện tại file này chỉ chuyển dữ liệu từ sheet DMHH sang có 4 cột, nếu e muốn chuyển hết 5 hoặc 6 cột thì chỉnh code như thế nào? Nhờ các bác giúp cho.
 

File đính kèm

Upvote 0
Chào các bác!

Mình mới học VBA, mình đang muốn viết 1 đoạn code xử lý dữ liệu từ file text, sau đó lấy một vài thông tin cần thiết và nhập vào file excel. Bác nào cho mình xin đoạn code tham khảo với.
Mình cảm ơn.
 
Upvote 0
Mình có được file excel DM nhưng bị lỗi như thế này nhờ các bác giúp:
1.
2.
3.
. . . .
Nhấp chuột vào đây để mở rộng...
Cách viết 1 dòng lệnh lại bỏ trống 1 dòng lệnh gây khó đọc quá; Mình không thể đọc nổi & xin chào vậy!
 
Upvote 0
Nhờ chỉ giúp chỗ mình chưa đúng trong đoạn code dưới. . Khi xóa dữ liệu tại cột B thì các cột khác cũng bị xóa ( Mình chỉ muốn xóa dữ liệu tại các cột A, L,M,N ( từ dòng 8 trở xuống ) để gán công thức mỗi khi có dữ liệu ở cột B (từ B8 )
Xin cảm ơn
Private Sub Worksheet_Change(ByVal Target As Range)
Application.EnableEvents = False
For Each Cll In Intersect(Target.EntireRow, [B:B])
If Cll.Row > 7 Then
If Cll.Value = "" Then
Range("A8:A1000", "L8:N1000").ClearContents

Else
If Range("A" & Cll.Row).Formula = "" Then Range("A" & Cll.Row).FormulaR1C1 = "=IF(RC[1]<>"""",MAX(R7C1:R[-1]C)+1,"""")"
If Range("L" & Cll.Row).Formula = "" Then Range("L" & Cll.Row).FormulaR1C1 = "=IF(RC[-10]="""","""",IF(RC[-5]=""x"",""x"",""/""))"
If Range("M" & Cll.Row).Formula = "" Then Range("M" & Cll.Row).FormulaR1C1 = "=IF(RC[-11]="""","""",IF(RC[-2]=R1C11,""Cdi"",IF(RC[-2]=R2C11,""Cde"",""/"")))"
If Range("N" & Cll.Row).Formula = "" Then Range("N" & Cll.Row).FormulaR1C1 = "=RIGHT(RC[-6],2)"
End If
End If
Next
Application.EnableEvents = True
End Sub
Nhấp chuột vào đây để mở rộng...
 

File đính kèm

Lần chỉnh sửa cuối:
Upvote 0
huongmuine đã viết:
Nhờ chỉ giúp chỗ mình chưa đúng trong đoạn code dưới. . Khi xóa dữ liệu tại cột B thì các cột khác cũng bị xóa ( Mình chỉ muốn xóa dữ liệu tại các cột A, L,M,N ( từ dòng 8 trở xuống ) để gán công thức mỗi khi có dữ liệu ở cột B (từ B8 )
Xin cảm ơn
Nhấp chuột vào đây để mở rộng...
Range("A8:A1000", "L8:N1000").ClearContents là lệnh xóa từ cột A đến cột L
muốn xóa từng cột thì dùng lệnh xóa riêng từng cột, hoặc tìm hiểu lệnh Union ghép các cột
 
Upvote 0
Status
Không mở trả lời sau này.

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

Q
Không chỉnh sửa, copy được hình ảnh trong file excel. (2 người xem)
Trả lời
6
Đọc
4K
thaivanthao
T
L
Nhờ giúp file word
Trả lời
1
Đọc
72
minhminh27
minhminh27
GPE-Trợ Lý
[GPE] TASKSHOW 14: TỪ BẢNG TÍNH ĐẾN BÁO CÁO ĐỘNG - BẮT ĐẦU VỚI LOOKER STUDIO
    • Thích
Trả lời
1
Đọc
11K
GPE-Trợ Lý
GPE-Trợ Lý
dungluyen2119
  • Question Question
Code VBA để tính tổng theo chiều ngang mà số cột không cố định
Trả lời
5
Đọc
252
dungluyen2119
dungluyen2119
ongke0711
  • Question Question
Tải hóa đơn điện tử (https://hoadondientu.gdt.gov.vn/) Excel Vba
    • Thích
    • Yêu thích
    • Cảm ơn
2 3 4
Trả lời
390
Đọc
46K
phdong
P
8
Theo dõi bán hàng
Trả lời
10
Đọc
296
84huong
8
L
  • Question Question
Nhờ sửa code ChrW ()
Trả lời
2
Đọc
89
le_vis
L
N
  • Question Question
Hỗ trợ tiếng việt trong macro
Trả lời
12
Đọc
522
Quang_Hải
Quang_Hải
D
xin hỏi về lỗi mô đun ẩn.
Trả lời
6
Đọc
292
du trung kien
D
haohvnh
Lỗi hàm SUM không hiển thị ra kết quả (1 người xem)
Trả lời
19
Đọc
45K
ptm0412
ptm0412
minhduc1o2
Hình ảnh bị lỗi #VALUE (1 người xem)
Trả lời
5
Đọc
170
minhduc1o2
minhduc1o2
ongke0711
  • Question Question
Tra cứu thông tin mã số thuế (cập nhật lại code cũ)
    • Thích
    • Cảm ơn
    • Yêu thích
Trả lời
5
Đọc
306
ongke0711
ongke0711
befaint
Chia sẻ tâm tư, xả nỗi lòng (2 người xem)
    • Thích
6 7 8
Trả lời
761
Đọc
61K
SA_DQ
SA_DQ
S
  • Question Question
Object.close và Set Object = nothing
Trả lời
14
Đọc
1K
nguyendang95
N
H
Lỗi khi sort data xin được hỗ trợ
Trả lời
2
Đọc
118
hunglq48
H
Nguyenkhang2404
Tính định mức sản phẩm
    • Chấp nhận
Trả lời
9
Đọc
370
Nguyenkhang2404
Nguyenkhang2404
T
Ngắt kết nối với tệp lệnh đính kèm
Trả lời
2
Đọc
135
TungXauGiai
T
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
2 3
Trả lời
277
Đọc
35K
joker102
J
S
tỷ lệ % không khớp khi cộng tổng
Trả lời
2
Đọc
109
snoobcool
S
D
Tên sheet bị che khuất khi thực hiện sửa tên sheet
Trả lời
1
Đọc
272
PhamMaiTB
P
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

Thời gian đếm ngược.

000
Ngày
00
Giờ
00
phút
00
giây
Thân mời tham dự sự kiện sinh nhật GPE 2025
Back
Top Bottom