Chuyên đề giải đáp những thắc mắc về 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)
maytinhvp01

maytinhvp01

Thành viên thường trực
Tham gia
27/7/13
Bài viết
390
Được thích
179
Mình muốn nhờ giải thich câu lệnh " If Ran.Cells(d, c) > max Then max = Ran.Cells(d, c) "
trong ví du:
Public Function LonNhat(Ran As Range)
Dim max As Double, v As Integer, d As Integer, c As Integer
max = Ran.Cells(1, 1)
For d = 1 To Ran.Rows.Count
For c = 1 To Ran.Columns.Count
If Ran.Cells(d, c) > max Then max = Ran.Cells(d, c)
Next c
Next d
v = Tim(max, Ran)
LonNhat = max
End Function
-------------------------------------------------------
[INFO1]Thông báo:
Vì topic này:
http://www.giaiphapexcel.com/forum/...ải-thích-các-code-đề-nghị-các-bạn-gửi-vào-đây
đã quá dài nên BQT đóng lại.
Nay tôi mở topic mới với cùng chủ đề: GIẢI THÍCH NHỮNG THẮC MẮC VỀ CODE
Các bạn nếu có nhu cầu giải thích code, vui lòng post tại đây nhé
NDU96081631
[/INFO1]
 
Chỉnh sửa lần cuối bởi điều hành viên:
Sắp xếp theo thời gian sắp xếp theo bầu chọn
SA_DQ đã viết:
Bạn xem file & chúc buổi sáng tốt lành!
Nhấp chuột vào đây để mở rộng...
Chào Bác. Giả sử trong một trang tính đó. Tồn tại cùng một mã hàng nhưng khác số lượng và ngày nhập, phương thức find chỉ hiển thị được 1 ạ. Có cách nào để nó hiển thị trên listbox hết không ?
 
Upvote 0
Mã: 
Private Sub txtBOOK_Change()
Dim Rws As Long
Dim Rng As Range, sRng As Range
With TONGHOP
    Rws = .Range("B" & Rows.Count).End(xlUp).Row
    Set Rng = .[F2].Resize(Rws)
    Set sRng = Rng.Find(Me!txtBOOK.Value, , xlValues, xlWhole)
    If sRng Is Nothing Then
   .Range("f" & Rws) = Me!txtBOOK.Text
    Else
        MsgBox "So book vua nhap da co!": Exit Sub
        End If
  End With
End Sub

Chào ACE GPE

Mình có cái code này, nó sẽ báo trùng dữ liệu khi ta nhập vào textbox.

Giờ mình muốn viết nó sang mảng thì làm sao vậy mọi người! chỉ giúp mình với (dữ liệu nằm cột F)
 
Upvote 0
Giả sử trong một trang tính đó. Tồn tại cùng một mã hàng nhưng khác số lượng và ngày nhập, với phương thức find có cách nào để nó hiển thị trên listbox hết không ?
Nhấp chuột vào đây để mở rộng...
PHP: 
Private Sub CommandButton1_Click()
Dim Sh As Worksheet, Rng As Range, sRng As Range
Dim Rws As Long, W As Integer, Col As Byte
Dim MyAdd As String
ReDim Arr(1 To 35, 1 To 6)
Arr(1, 1) = "STT":                             Arr(1, 2) = "Ngày Tháng"
Arr(1, 3) = "Mã Hàng":                     Arr(1, 4) = "Sô Luong"
Arr(1, 5) = "Kê Sô":                           Arr(1, 6) = "Trang tính"
W = 1
For Each Sh In ThisWorkbook.Worksheets
    If Left(Sh.Name, 3) = "Kho" Then
        Rws = Sh.[B1].CurrentRegion.Rows.Count
        Set Rng = Sh.[B1].Resize(Rws)
        Set sRng = Rng.Find(Me!Txt_MH.Text, , xlFormulas, xlWhole)
        If Not sRng Is Nothing Then
            MyAdd = sRng.Address
            Do
                W = W + 1:                          Arr(W, 1) = W - 1
                Arr(W, 6) = Sh.Name
                For Col = 1 To 4
                    Arr(W, Col + 1) = Sh.Cells(sRng.Row, Col).Value
                Next Col
3               Set sRng = Rng.FindNext(sRng)   '<=|    '
            Loop While sRng.Address <> MyAdd
        End If
    End If
Next Sh
Me!lbDS.List = Arr()
End Sub
 
Upvote 0
SA_DQ đã viết:
PHP: 
Private Sub CommandButton1_Click()
Dim Sh As Worksheet, Rng As Range, sRng As Range
Dim Rws As Long, W As Integer, Col As Byte
Dim MyAdd As String
ReDim Arr(1 To 35, 1 To 6)
Arr(1, 1) = "STT":                             Arr(1, 2) = "Ngày Tháng"
Arr(1, 3) = "Mã Hàng":                     Arr(1, 4) = "Sô Luong"
Arr(1, 5) = "Kê Sô":                           Arr(1, 6) = "Trang tính"
W = 1
For Each Sh In ThisWorkbook.Worksheets
    If Left(Sh.Name, 3) = "Kho" Then
        Rws = Sh.[B1].CurrentRegion.Rows.Count
        Set Rng = Sh.[B1].Resize(Rws)
        Set sRng = Rng.Find(Me!Txt_MH.Text, , xlFormulas, xlWhole)
        If Not sRng Is Nothing Then
            MyAdd = sRng.Address
            Do
                W = W + 1:                          Arr(W, 1) = W - 1
                Arr(W, 6) = Sh.Name
                For Col = 1 To 4
                    Arr(W, Col + 1) = Sh.Cells(sRng.Row, Col).Value
                Next Col
3               Set sRng = Rng.FindNext(sRng)   '<=|    '
            Loop While sRng.Address <> MyAdd
        End If
    End If
Next Sh
Me!lbDS.List = Arr()
End Sub
Nhấp chuột vào đây để mở rộng...
Cám ơn bác. nhân tiện Bác cho e hỏi thêm chỗ này :
3 Set sRng = Rng.FindNext(sRng) '<=| ' Loop While sRng.Address <> MyAdd
thấy khi Set sRng = findNext rồi thì điều kiện đúng, vậy sao nó vẫn Do được các vòng tiếp theo nhỉ.?
 
Upvote 0
noinhodayvoi20_10 đã viết:
Cám ơn bác. nhân tiện Bác cho e hỏi thêm chỗ này :
3 Set sRng = Rng.FindNext(sRng) '<=| ' Loop While sRng.Address <> MyAdd
thấy khi Set sRng = findNext rồi thì điều kiện đúng, vậy sao nó vẫn Do được các vòng tiếp theo nhỉ.?
Nhấp chuột vào đây để mở rộng...
Thì nó cũng giống như:
k = k + 1
Debug.Print k
------------------------
Debug.Print k
k = k + 1

Điều kiện đúng ở While cuối dòng sẽ lặp 1 lần cuối
 
Upvote 0
CHO MÌNH HỎI CODE NÀY SAI Ở ĐÂU Ạ? SAO NÓ K CHẠY!

Mã: 
Private Sub txtBOOK_Change()
Dim vung(), dongcuoi As Long
Dim i As Long
    dongcuoi = Range("f" & Rows.Count).End(xlUp).Row
    vung = Range("a2:w" & dongcuoi).Value
  
    For i = LBound(vung, 1) To UBound(vung, 1) Step 1
    If vung(i, 6) = Me!txtBOOK.Value Then
    MsgBox "trung": Exit For
    End If
    Next i
End Sub
 
Upvote 0
noinhodayvoi20_10 đã viết:
Cám ơn bác. nhân tiện Bác cho e hỏi thêm chỗ này :
3 Set sRng = Rng.FindNext(sRng) '<=| ' Loop While sRng.Address <> MyAdd
thấy khi Set sRng = findNext rồi thì điều kiện đúng, vậy sao nó vẫn Do được các vòng tiếp theo nhỉ.?
Nhấp chuột vào đây để mở rộng...
hiểu
While = trong khi
trong khi điều kiện còn ĐÚNG thì tiếp tục LẶP
 
Upvote 0
tam888 đã viết:
Chắc nó là cái này
https://www.seagullscientific.com/label-software/barcode-label-design-and-printing/

Tôi thì nghĩ , người dùng nên chịu khó bấm in đi, sao tự động với VBA có nhanh hơn không, số lượng in nhiều không?
Nhấp chuột vào đây để mở rộng...
Bên mình scan vào excel đối chiếu có phải đúng thứ mình cần ko sau đó sẽ chia số lượng ra theo đơn hàng. Thường là chia làm 2 hoặc 3. Một ngày scan khoảng 1k lần
 
Upvote 0
Upvote 0
Các anh chị có thể cho em hỏi là sao cho em hỏi là tại sao code vlookup của em nó cứ bắt update file mới chạy nhỉ mọi người
Code như sao :

Cells("CS1"). FormulaR2C1 = Vlookup(Q2, '[data.xlxs]12.14.18$A:$L',2,0)

Trong khi đó file data vẫn nằm cố định ở chỗ cũ, em đã thử thêm vào đường dẫn link nhưng kết quả lại ra toàn #N/A
 
Upvote 0
Các thầy cùng mn cho e hỏi.
Có sự kiện nào trên From giống before_close không ạ.
Nghĩa là nếu đóng from thì file sẽ đóng luôn và tự động lưu file ạ.
Do gán nút lên From thì cài nút đc, nhưng nó lại còn có nút tắt trên góc phải nữa. Nên k biết làm sao
 
Upvote 0
noinhodayvoi20_10 đã viết:
Các thầy cùng mn cho e hỏi.
Có sự kiện nào trên From giống before_close không ạ.
Nghĩa là nếu đóng from thì file sẽ đóng luôn và tự động lưu file ạ.
Do gán nút lên From thì cài nút đc, nhưng nó lại còn có nút tắt trên góc phải nữa. Nên k biết làm sao
Nhấp chuột vào đây để mở rộng...
Đừng viết tắt như: r, qá, mn, e, đc, k.

Viết cho bạn bè quen biết cùng trang lứa thế nào cũng được, nhưng viết như thế trên diễn đàn đủ loại người, lứa tuổi, không quen biết là không tôn trọng người ta.

Có nhiều kiểu đóng, hủy Form. Cho dù đóng bằng cách nào thì code UserForm_QueryClose, nếu có, sẽ được thực hiện.

Vậy hãy tạo code cho UserForm_QueryClose. Trong code thì kiểm tra, cái gì là thủ phạm đóng, hủy Form. Rồi tùy vào thủ phạm và dụng ý của mình để có các cách xử lý khác nhau.

- CloseMode = vbFormControlMenu = 0: người dùng đã đóng Form bằng cách nhấn X ở góc phải phía trên, hoặc phải chuột trên thanh tiêu đề rồi chọn menu Close, hoặc nhấn tổ hợp Alt + F4. Lúc đó code QueryClose sẽ được thực hiện với CloseMode = vbFormControlMenu = 0

- CloseMode = vbFormCode = 1: Unload đã được gọi ở đâu đó, vd. trong CommandButton1_Click. Lúc đó code QueryClose sẽ được thực hiện với CloseMode = vbFormCode = 1

- CloseMode = vbAppWindows = 2: người dùng đóng Windows. Nếu người dùng đóng Windows thì Windows sẽ đóng các ứng dụng đang chạy trong đó có cả Excel, vì thế Form cũng bị đóng, tức code QueryClose sẽ được thực hiện với CloseMode = vbAppWindows = 2

- CloseMode = vbAppTaskManager = 3: người dùng kích hoạt Task Manager và thông qua nó đóng Excel, vì thế Form cũng bị đóng, tức code QueryClose sẽ được thực hiện với CloseMode = vbAppTaskManager = 3

Tự thử nghiệm với parameter Cancel. Đây là giá trị trả về. Tức có thể thiết lập Cancel = True, hoặc Cancel = False. Không thiết lập thì giống như thiết lập Cancel = False, vì Cancel = False được truyền vào UserForm_QueryClose
 
Upvote 0
Các thấy và mọi người giúp em với
Em có 1 đoạn vba
Giờ em muốn ô a1 =1 thì chạy lệnh vba được
Còn nếu a1 # 1 thì. Hiên thông báo
 
Upvote 0
Các anh cho e hỏi là cách nào xài if với #N/A không ạ, em đã thử format sang text, past value nhưng cứ khi dùng code
If Cells(i, "Cột") =" #N/A"
thì nó cứ bảo lỗi typemissmatch ạ
 
Upvote 0
harukenshiro đã viết:
Các anh cho e hỏi là cách nào xài if với #N/A không ạ, em đã thử format sang text, past value nhưng cứ khi dùng code
If Cells(i, "Cột") =" #N/A"
thì nó cứ bảo lỗi typemissmatch ạ
Nhấp chuột vào đây để mở rộng...

Đã VBA lại còn ứng dụng công thức nữa (vì #N/A thường là do công thức hàm excel trả về)
Nếu vẫn thích thế, thì để kiểm #N/A trong VBA thì xem gợi ý sau sẽ hiểu (bài này sưu tầm từ internet làm ví dụ)
Mã: 
Public Function checkCells(Rg As Range) As Boolean
    Dim result As Boolean, r
    result = False
    For Each r In Rg
        If Application.WorksheetFunction.IsNA(r) Then
            result = True
            Exit For
        End If
    Next
    checkCells = result
End Function
 
Upvote 0
Cho em hỏi trong VBA có hàm nào giúp làm tròn giây thành 0 không, Ví dụ 12/7/2018 8:03:41 PM em muốn làm tròn thành 12/7/2018 8:03:00 PM (Tất cả số giây từ 1 đến 59s đều làm tròn về 0)
 
Upvote 0
Sau khi nhờ thầy @Ba Tê viết code cho file mà em muốn sử dụng. nó có 1 vài vấn đề mà em mong muốn nhờ các anh chị tìm cách giúp với.

Ở file đính kèm và hình ảnh

Hiện tại các kết quả trả về cho các cột F, N ( bôi vàng) đều Ok.

Em muốn nhờ các anh chị, thầy cô xem có viết được 1 đoạn code thỏa mãn yêu cầu như sau của em:

Khi em nhập sản phẩm vào ô C11. ở file “sau khi viet code” thì ô C12, C13 nó cũng sẽ nhảy theo. è giờ em muốn là: Khi nhập ở C11 thì các ô sau liền kề tiếp theo có giá trị giống thì ẩn đi hoặc được bôi màu trắng để khi in không thấy ( như file “ nhập tay”

Và khi nhập số lượng tại ô D11 thì số lượng bên cột I11-I12-I13 sẽ thay đổi luôn theo công thức đã định sẵn không ạ.

Xin cám ơn ạ. ( do file của em đính kèm lên. Thấy thầy @Ba Tê nói có vi rút với nhiều file rác nên em mới đính kèm hình ảnh). Mong các anh chị, thầy cô thông cảm ạ.
code của thầy ấy đây ạ:
Mã: 
Private Sub Worksheet_Change(ByVal Target As Range)
Dim sArr(), dArr(), tArr(), I As Long, K As Long, R As Long, Txt As String
Application.EnableEvents = False
If Not Intersect(Target, Range("C11:C5000")) Is Nothing Then
    If Target.Count = 1 Then
        sArr = Sheets("Data").Range("A3", Sheets("Data").Range("A3").End(xlDown)).Resize(, 6).Value
        R = UBound(sArr)
        K = -1
        With Target
            Txt = .Value
            For I = 1 To R
                If sArr(I, 2) = Txt Then
                    K = K + 1
                    .Offset(K) = Txt
                    .Offset(K, -1) = sArr(I, 1)
                    .Offset(K, 3) = sArr(I, 3)
                    .Offset(K, 4) = sArr(I, 6)
                    .Offset(K, 6) = "=RC[-5]*RC[-3]+(RC[-5]*RC[-3]*RC[-1])"
                    .Offset(K, 7) = sArr(I, 6)
                    .Offset(K, 9) = sArr(I, 6)
                    .Offset(K, 10) = sArr(I, 5)
                    .Offset(K, 11) = sArr(I, 4)
                End If
            Next I
        End With
    End If
End If
Application.EnableEvents = True
End Sub
 

File đính kèm

  • Nhap tay.png
    Nhap tay.png
    171.2 KB · Đọc: 11
  • Sau khi viet code.png
    Sau khi viet code.png
    158.7 KB · Đọc: 10
  • form chung.xlsm
    form chung.xlsm
    57.1 KB · Đọc: 10
Lần chỉnh sửa cuối:
Upvote 0
buiquangthuan đã viết:
Sau khi nhờ thầy @Ba Tê viết code cho file mà em muốn sử dụng. nó có 1 vài vấn đề mà em mong muốn nhờ các anh chị tìm cách giúp với.

Ở file đính kèm và hình ảnh

Hiện tại các kết quả trả về cho các cột F, N ( bôi vàng) đều Ok.

Em muốn nhờ các anh chị, thầy cô xem có viết được 1 đoạn code thỏa mãn yêu cầu như sau của em:

Khi em nhập sản phẩm vào ô C11. ở file “sau khi viet code” thì ô C12, C13 nó cũng sẽ nhảy theo. è giờ em muốn là: Khi nhập ở C11 thì các ô sau liền kề tiếp theo có giá trị giống thì ẩn đi hoặc được bôi màu trắng để khi in không thấy ( như file “ nhập tay”

Và khi nhập số lượng tại ô D11 thì số lượng bên cột I11-I12-I13 sẽ thay đổi luôn theo công thức đã định sẵn không ạ.

Xin cám ơn ạ. ( do file của em đính kèm lên. Thấy thầy @Ba Tê nói có vi rút với nhiều file rác nên em mới đính kèm hình ảnh). Mong các anh chị, thầy cô thông cảm ạ.
Nhấp chuột vào đây để mở rộng...
Code đâu làm gì thấy cái code nào bạn.Thấy rồi bạn nhé.Nhưng không hiểu nên không sửa.:D.
 
Lần chỉnh sửa cuối:
Upvote 0
tam888 đã viết:
Đã VBA lại còn ứng dụng công thức nữa (vì #N/A thường là do công thức hàm excel trả về)
Nếu vẫn thích thế, thì để kiểm #N/A trong VBA thì xem gợi ý sau sẽ hiểu (bài này sưu tầm từ internet làm ví dụ)
Mã: 
Public Function checkCells(Rg As Range) As Boolean
    Dim result As Boolean, r
    result = False
    For Each r In Rg
        If Application.WorksheetFunction.IsNA(r) Then
            result = True
            Exit For
        End If
    Next
    checkCells = result
End Function
Nhấp chuột vào đây để mở rộng...

Cảm ơn anh đã trả lời, ý tưởng ở đây của em là vlookup từ rất nhiều file khác nhau vào một file gốc, nếu có dữ liệu => nó thuộc production đó, không có dữ liêu( tức là bị #N/A) thì vlookup file của bộ phận khác đến khi hết #N/A thì thôi
 
Upvote 0
harukenshiro đã viết:
Cảm ơn anh đã trả lời, ý tưởng ở đây của em là vlookup từ rất nhiều file khác nhau vào một file gốc, nếu có dữ liệu => nó thuộc production đó, không có dữ liêu( tức là bị #N/A) thì vlookup file của bộ phận khác đến khi hết #N/A thì thôi
Nhấp chuột vào đây để mở rộng...
Đã VBA thì tìm hiểu Find của Range xem sao, dùng Vlookup làm chi cho rối và chậm
 
Upvote 0
Thầy nào viết giúp em đoạn code nào mà xóa được dữ lieu nhập trước đó không ạ.
Trước đó có 1 đoạn code. Khi em nhập. Nó tự động nhảy ra rất nhiều dữ liệu ở các cột khác.
Nếu em nhập sai dữ liệu đầu vào. Mà em muốn xóa đi. Thì các ô được nhảy dữ liệu trước đó sẽ cũng được xóa.
 
Upvote 0
buiquangthuan đã viết:
Thầy nào viết giúp em đoạn code nào mà xóa được dữ lieu nhập trước đó không ạ.
Trước đó có 1 đoạn code. Khi em nhập. Nó tự động nhảy ra rất nhiều dữ liệu ở các cột khác.
Nếu em nhập sai dữ liệu đầu vào. Mà em muốn xóa đi. Thì các ô được nhảy dữ liệu trước đó sẽ cũng được xóa.
Nhấp chuột vào đây để mở rộng...
Vậy bạn xác định lại các vùng bạn ghi thêm vào đó rồi xóa nó đi.Ghi vào được chắc xác định vị trí cũng được chứ nhỉ.
 
Upvote 0

File đính kèm

Upvote 0
snow25 đã viết:
Bây giờ bạn muốn xóa dữ liệu ở sheets nào.
Nhấp chuột vào đây để mở rộng...
Ban đầu là khi em nhập dữ liệu từ cột C11 ( sheet Form) thì các ô B11,E11,F11,G11,H,J,L,M,N11 tự động nhảy theo. Nếu giờ em xóa C11 đi thì các ô còn lại cũng tự động xóa được không ạ
 
Upvote 0
buiquangthuan đã viết:
Ban đầu là khi em nhập dữ liệu từ cột C11 ( sheet Form) thì các ô B11,E11,F11,G11,H,J,L,M,N11 tự động nhảy theo. Nếu giờ em xóa C11 đi thì các ô còn lại cũng tự động xóa được không ạ
Nhấp chuột vào đây để mở rộng...
Vậy bạn xóa luôn dòng đấy đi code chi cho mệt.
 
Upvote 0
Xin chào các bạn,
Oanh Thơ(OT) có sưu tầm một câu lệnh như sau để lấy dữ liệu bằng phương pháp GetOpenFilename.

Mã: 
Sub GetImportValues()
'https://stackoverflow.com/questions/22248800/vba-how-to-import-values-from-several-excel-files-selected-by-users-via-dialog
    Dim filenames, f
    Dim myMsg As String
    Dim wb As Workbook
    Dim lastrow As Long
    'Get the filename
    filenames = Application.GetOpenFilename(FileFilter:="Excel VBA files (*.xls*), *.xls*", _
                                            FilterIndex:=1, _
                                            Title:="pls select the excel files to Import", _
                                            MultiSelect:=True)
    If IsArray(filenames) Then
        myMsg = "You selected:" & vbNewLine
        'Display full path and name of the files
        For Each f In filenames
            myMsg = myMsg & f & vbNewLine
        Next f
        MsgBox myMsg
    Else
        MsgBox "No excel file was selected."
        Exit Sub
    End If

    For Each f In filenames
        Set wb = Workbooks.Open(f)

        With ThisWorkbook.Sheets("Results")
            'determine last non empty row in column A sheet "Result" to past result
            lastrow = Application.Max(3, .Cells(.Rows.Count, "A").End(xlUp).Row + 1)
            .Range("A" & lastrow).Value = wb.Sheets("Sheet1").Range("I3").Value
        End With

        wb.Close SaveChanges:=False
        Set wb = Nothing
    Next f
End Sub

-------------
Mong muốn của OT làm sao chỉ chọn được 2 tập tin muốn lấy (2 tập tin này để trong cùng một thư mục, nhưng khác với thư mục chứa tập tin chạy code "ThisWorkbook.Name")
Và mỗi tập tin được chọn sẽ đưa dữ liệu vào sheet khác nhau của tập tin chạy code "ThisWorkbook.Name".

Ví dụ:
Khi chạy code hiện cửa sổ tìm đến thư mục XYZ
lựa chọn 2 tập tin A.xls và B.xls nằm trong cùng một thư mục : XYZ
Tập tin A.xls sẽ đổ dữ liệu vào ThisWorkbook.Sheets("Results1").range("A1")
Tập tin B.xls sẽ đổ dữ liệu vào ThisWorkbook.Sheets("Results2").range("A1")

Thì code trên phải sửa sao ạ?
 
Upvote 0
HeSanbi đã viết:
Nguyễn Hoàng Oanh Thơ
Hôm trước thấy OT trả lời "Lấy dữ liệu file đang đóng", hôm nay thấy OT thắc mắc gần giống với tiêu đề đấy.
Gặp vấn đề khó phải không OT?
Nhấp chuột vào đây để mở rộng...
Dạ vâng, vấn đề làm sao để lựa chọn được 2 tập tin và mỗi tập tin lựa chọn sẽ trả dữ liệu về mỗi sheet khác nhau, như OT đã nêu ạ:
Ví dụ:
Khi chạy code hiện cửa sổ tìm đến thư mục XYZ
lựa chọn 2 tập tin A.xls và B.xls nằm trong cùng một thư mục : XYZ
Tập tin A.xls sẽ đổ dữ liệu vào ThisWorkbook.Sheets("Results1").range("A1")
Tập tin B.xls sẽ đổ dữ liệu vào ThisWorkbook.Sheets("Results2").range("A1")
Nhấp chuột vào đây để mở rộng...
Nhờ @HeSanbi và các bạn hỗ trợ ạ
 
Upvote 0
Upvote 0
HeSanbi đã viết:
Đoạn này chọn bằng tay hay VBA làm vậy OT. Nếu VBA làm thì không cần hiện cửa sổ
Nhấp chuột vào đây để mở rộng...
@HeSanbi
Đoạn này chọn tay ạ, sử dụng GetOpenFilename bởi vì đường dẫn và tên file tên sheet thường xuyên phải sửa tay ạ. Nên dùng code để xử lý thì không được.
 
Upvote 0
Nguyễn Hoàng Oanh Thơ đã viết:
@HeSanbi
Đoạn này chọn tay ạ, sử dụng GetOpenFilename bởi vì đường dẫn và tên file tên sheet thường xuyên phải sửa tay ạ. Nên dùng code để xử lý thì không được.
Nhấp chuột vào đây để mở rộng...
Có nhiều cách để làm việc này:
1. Đổi tên sheets(1) ở file A.xls thành "Result1" Move sang ThisWorkbook
2. Xác định vùng sheets(1) chứa dữ liệu ở file A.xls copy sang Sheets("Result1") ThisWorkbook:
+ Nếu dữ liệu liền mảng thì dùng CurrentRegion sẽ hợp lý
+ Nếu dữ liệu rời rạc thì Copy cả sheet
Tham khảo thêm cách Select File / Folder ở đây nhé OT: Link
Với code dưới OT thêm bẫy lỗi nếu Hủy không chọn File
Mã: 
Sub Test()
Dim Arr
  Arr =  FileOpen("D:\XYZ",  ""  ,"*.xls; *.xlsx; *.xlsm")
'dbPrint Arr
End Sub

Function FileOpen(initialFilename As String, _
  Optional sDesc As String = "Excel (*.xls)", _
  Optional sFilter As String = "*.xls") As Variant
  On Error GoTo Ends
  Dim Arr(), k, it
  With Application.FileDialog(msoFileDialogOpen)
    .ButtonName = "&Open"
    .initialFilename = initialFilename
    .Filters.Clear
    .Filters.Add sDesc, sFilter, 1
    .Title = "File Open"
    .AllowMultiSelect = True
    If .show = -1 Then
      For Each it In .SelectedItems
        ReDim Preserve Arr(k)
        Arr(k) = it
        k = k + 1
      Next it
    End If
    FileOpen = Arr
  End With
  Exit Function
Ends:
  FileOpen = Array()
End Function


If f Like "*\[A].xls" Then
'..........
Arr = wb.sheets(1).[A1].CurrentRegion.value
ThisWorkbook.Sheets("Result1").[A1].Resize(Ubound(Arr),Ubound(Arr, 2)).Value = Arr
'.........
End if
If f Like "*\[B].xls" Then
'..........
Arr = wb.sheets(1).[A1].CurrentRegion.value
ThisWorkbook.Sheets("Result2").[A1].Resize(Ubound(Arr),Ubound(Arr, 2)).Value = Arr
'.........
End if
 
Lần chỉnh sửa cuối:
Upvote 0
Cảm ơn @HeSanbi nhiều ạ,
Bạn có thể chỉ giúp OT cách sử dụng GetOpenFilename như bài 1797 được không ạ?
OT chưa tìm hiểu sự khác nhau giữa GetOpenFilename và FileDialog nhưng cảm thấy thích sử dụng GetOpenFilename hơn ạ.
 
Upvote 0
Nguyễn Hoàng Oanh Thơ đã viết:
cách sử dụng GetOpenFilename như bài 1797
Nhấp chuột vào đây để mở rộng...
Tức là cái khó nhất với OT là GetOpenFilename
GetOpenFilename - Được định nghĩa là Hàm - "Thượng cổ" (Excel)
FileDialog là Một Object - hướng đối tượng - "Hiện đại" (Office) , gồm thuộc tính của GetOpenFilename và nhiều hơn
OT vào đây nếu cảm thấy muốn hiểu sâu hơn: Microsoft Docs
Và OT thử nói ước muốn rõ ràng hơn tí đi
 
Upvote 0
Nguyễn Hoàng Oanh Thơ đã viết:
@HeSanbi
Đoạn này chọn tay ạ, sử dụng GetOpenFilename bởi vì đường dẫn và tên file tên sheet thường xuyên phải sửa tay ạ. Nên dùng code để xử lý thì không được.
Nhấp chuột vào đây để mở rộng...
Nếu bắt buộc phải chọn 2 tập tin thì nên cho phương án xử lý khi: người dùng chọn 1, hoặc người dùng chọn 3, 4, 5, ... tập tin.

1. Lặp lại, nhưng không quá 10 lần (20 lần), cho tới tận khi chọn đúng 2 tập tin?
2. Không lặp lại mà kết thúc cuộc chơi?
3. Nếu chọn > 2 thì cũng không lặp lại mà chỉ lấy 2 tập tin đầu, hoặc 2 tập tin cuối, hoặc tung đồng xu rút thăm 2 tập tin?
 
Upvote 0
batman1 đã viết:
Nếu bắt buộc phải chọn 2 tập tin thì nên cho phương án xử lý khi: người dùng chọn 1, hoặc người dùng chọn 3, 4, 5, ... tập tin.

1. Lặp lại, nhưng không quá 10 lần (20 lần), cho tới tận khi chọn đúng 2 tập tin?
2. Không lặp lại mà kết thúc cuộc chơi?
3. Nếu chọn > 2 thì cũng không lặp lại mà chỉ lấy 2 tập tin đầu, hoặc 2 tập tin cuối, hoặc tung đồng xu rút thăm 2 tập tin?
Nhấp chuột vào đây để mở rộng...

Con chào bác Siwtom,
Dạ bác xem giúp con trường hợp lấy dữ liệu theo phương án 1 ạ:
1. Lặp lại, nhưng không quá 3 lần, cho tới tận khi chọn đúng 2 tập tin?
Con cảm ơn bác.
 
Upvote 0
Nguyễn Hoàng Oanh Thơ đã viết:
Con chào bác Siwtom,
Dạ bác xem giúp con trường hợp lấy dữ liệu theo phương án 1 ạ:
1. Lặp lại, nhưng không quá 3 lần, cho tới tận khi chọn đúng 2 tập tin?
Con cảm ơn bác.
Nhấp chuột vào đây để mở rộng...
Mã: 
Sub GetImportValues()
Const startdir = "D:\XYZ"
Const allowcount = 3
Const filescount = 2
Dim filenames
Dim repeat As Long
    ChDrive Left(startdir, 1)
    ChDir startdir
    repeat = 1
    Do While repeat <= allowcount
        filenames = Application.GetOpenFilename("Excel files (*.xls; *.xlsx; *.xlsm; *.xlsb),*.xls; *.xlsx; *.xlsm; *.xlsb", , _
                                            "H" & ChrW(227) & "y ch" & ChrW(7885) & "n 2 t" & ChrW(7853) & "p tin", , True)
        If IsArray(filenames) Then
            If UBound(filenames) = filescount Then Exit Do
        End If
        repeat = repeat + 1
    Loop
    MsgBox repeat
    If repeat > allowcount Then Exit Sub
'    o cho nay trong filenames co 2 tap tin. Tiep theo lam gi thi lam
End Sub
 
Upvote 0
batman1 đã viết:
Mã: 
Sub GetImportValues()
Const startdir = "D:\XYZ"
Const allowcount = 3
Const filescount = 2
Dim filenames
Dim repeat As Long
    ChDrive Left(startdir, 1)
    ChDir startdir
    repeat = 1
    Do While repeat <= allowcount
        filenames = Application.GetOpenFilename("Excel files (*.xls; *.xlsx; *.xlsm; *.xlsb),*.xls; *.xlsx; *.xlsm; *.xlsb", , _
                                            "H" & ChrW(227) & "y ch" & ChrW(7885) & "n 2 t" & ChrW(7853) & "p tin", , True)
        If IsArray(filenames) Then
            If UBound(filenames) = filescount Then Exit Do
        End If
        repeat = repeat + 1
    Loop
    MsgBox repeat
    If repeat > allowcount Then Exit Sub
'    o cho nay trong filenames co 2 tap tin. Tiep theo lam gi thi lam
End Sub
Nhấp chuột vào đây để mở rộng...

Cảm ơn bác Siwtom,
Con muốn đưa dữ liệu từ 2 file lấy được trong filenames:
Lấy dữ liệu sheets(1) file vị trí 1 (file chọn trước) đưa vào sheet1 của file Laydulieu.xlsm
Lấy dữ liệu sheets(1) file vị trí 2 (file chọn sau) đưa vào sheet2 của file Laydulieu.xlsm
Laydulieu.xlsm là file chứa code trên "sub GetImportValues" ạ.
Con chưa biết cách làm tiếp bước này, bác chỉ giúp con ạ.
Bài đã được tự động gộp:

HeSanbi đã viết:
Tức là cái khó nhất với OT là GetOpenFilename
GetOpenFilename - Được định nghĩa là Hàm - "Thượng cổ" (Excel)
FileDialog là Một Object - hướng đối tượng - "Hiện đại" (Office) , gồm thuộc tính của GetOpenFilename và nhiều hơn
OT vào đây nếu cảm thấy muốn hiểu sâu hơn: Microsoft Docs
Và OT thử nói ước muốn rõ ràng hơn tí đi
Nhấp chuột vào đây để mở rộng...
Cảm ơn @HeSanbi,
Thì ra GetOpenFilename là đồ cổ, OT lạc hậu thật..hihi
Nhờ bạn mà OT lại biết thêm một thông tin mới.
 
Lần chỉnh sửa cuối:
Upvote 0
Nguyễn Hoàng Oanh Thơ đã viết:
Cảm ơn bác Siwtom,
Con muốn đưa dữ liệu từ 2 file lấy được trong filenames:
Lấy dữ liệu sheets(1) file vị trí 1 (file chọn trước) đưa vào sheet1 của file Laydulieu.xlsm
Lấy dữ liệu sheets(1) file vị trí 2 (file chọn sau) đưa vào sheet2 của file Laydulieu.xlsm
Laydulieu.xlsm là file chứa code trên "sub GetImportValues" ạ.
Con chưa biết cách làm tiếp bước này, bác chỉ giúp con ạ.
Nhấp chuột vào đây để mở rộng...
Việc xử lý 2 tập tin thì HeSanbi đã hướng dẫn bạn rồi còn gì.
 
Upvote 0
Code Copy từ Sheet này sang Sheet khác
Các bạn giúp code hoặc chỉ đường Link (nếu có) như sau:
Trong 1 file, em muốn copy từ Sheet A sang Sheet B như sau:
* Sheet A: tại cột D, E, F có dữ liệu từ dòng thứ 5 trở xuống
1/Em muốn copy số liệu cột D, E và sang sheet B dán tại cột F, G
2/Em muốn copy số liệu cột F và sang sheet B dán tại cột I
Bắt đầu dán từ dòng số 9 (Xem file đính kèm)Xin cảm ơn
 

File đính kèm

Upvote 0
@Nguyễn Hoàng Oanh Thơ
Lời khuyên vẫn nên vận dụng cái "hiện đại".
Nghe OT nói đang học VBA không biết học tới đâu rồi.
Hôm trước thấy trả lời bài viết rất tốt. Sao nay lại chững bước với vấn đề tương tự thế này

Code dưới gọn gàn hơn Code tôi gợi ý lúc trước
PHP: 
Function GetFileFullname(FolderPath As String, Optional sDesc As String = "Excel", _
                                             Optional sFilter As String = "*.xls") As Variant
  GetFileFullname = Array()
  Dim Arr(), k, it
  With Application.FileDialog(msoFileDialogOpen)
    .ButtonName = "&Open" 'Nút chỉ thị
    .initialFilename = FolderPath 'Đi đến đường dẫn cho trước
    '.Filters.Delete(1) '
    .Filters.Clear 'Xóa gợi ý các loại tệp mở rộng
    .Filters.Add sDesc, sFilter 'Bắt đầu thêm lại Gợi ý - Mặc định
    .Filters.Add "All File", "*.*" 'Thêm 1 Gợi ý nữa
    .Title = "File Open" 'Tiêu đề
    .InitialView = msoFileDialogViewDetails 'Kiểu sắp xếp để xem
    .AllowMultiSelect = True 'Cho phép chọn nhiều tệp
    If .show = -1 Then
      For Each it In .SelectedItems
        ReDim Preserve Arr(k): Arr(k) = it
        k = k + 1
      Next it
      GetFileFullname = Arr
    End If
  End With
End Function
 
Lần chỉnh sửa cuối:
Upvote 0
Nguyễn Hoàng Oanh Thơ đã viết:
Xin chào các bạn,
Oanh Thơ(OT) có sưu tầm một câu lệnh như sau để lấy dữ liệu bằng phương pháp GetOpenFilename.

Mã: 
Sub GetImportValues()
'https://stackoverflow.com/questions/22248800/vba-how-to-import-values-from-several-excel-files-selected-by-users-via-dialog
    Dim filenames, f
    Dim myMsg As String
    Dim wb As Workbook
    Dim lastrow As Long
    'Get the filename
    filenames = Application.GetOpenFilename(FileFilter:="Excel VBA files (*.xls*), *.xls*", _
                                            FilterIndex:=1, _
                                            Title:="pls select the excel files to Import", _
                                            MultiSelect:=True)
    If IsArray(filenames) Then
        myMsg = "You selected:" & vbNewLine
        'Display full path and name of the files
        For Each f In filenames
            myMsg = myMsg & f & vbNewLine
        Next f
        MsgBox myMsg
    Else
        MsgBox "No excel file was selected."
        Exit Sub
    End If

    For Each f In filenames
        Set wb = Workbooks.Open(f)

        With ThisWorkbook.Sheets("Results")
            'determine last non empty row in column A sheet "Result" to past result
            lastrow = Application.Max(3, .Cells(.Rows.Count, "A").End(xlUp).Row + 1)
            .Range("A" & lastrow).Value = wb.Sheets("Sheet1").Range("I3").Value
        End With

        wb.Close SaveChanges:=False
        Set wb = Nothing
    Next f
End Sub

-------------
Mong muốn của OT làm sao chỉ chọn được 2 tập tin muốn lấy (2 tập tin này để trong cùng một thư mục, nhưng khác với thư mục chứa tập tin chạy code "ThisWorkbook.Name")
Và mỗi tập tin được chọn sẽ đưa dữ liệu vào sheet khác nhau của tập tin chạy code "ThisWorkbook.Name".

Ví dụ:
Khi chạy code hiện cửa sổ tìm đến thư mục XYZ
lựa chọn 2 tập tin A.xls và B.xls nằm trong cùng một thư mục : XYZ
Tập tin A.xls sẽ đổ dữ liệu vào ThisWorkbook.Sheets("Results1").range("A1")
Tập tin B.xls sẽ đổ dữ liệu vào ThisWorkbook.Sheets("Results2").range("A1")

Thì code trên phải sửa sao ạ?
Nhấp chuột vào đây để mở rộng...
Nếu đã có điều kiện cho mỗi file (đặc điểm nhận dạng cho từng loại file A và B) thì lọc luôn khi chọn - tức là chỉ hiển thị các file hợp lệ để chọn. Đồng thời, khi chọn xong thì kiểm tra luôn có phải đã chọn 1 file dạng A và 1 file dạng B không, nếu không phải thì yêu cầu chọn lại chứ đừng để cho chọn rồi rồi lại bảo chọn không đúng.
Bạn xem code và dữ liệu mẫu trong file đính kèm.
 

File đính kèm

Upvote 0
HeSanbi đã viết:
@Nguyễn Hoàng Oanh Thơ
Lời khuyên vẫn nên vận dụng cái "hiện đại".
Nghe OT nói đang học VBA không biết học tới đâu rồi.
Hôm trước thấy trả lời bài viết rất tốt. Sao nay lại chững bước với vấn đề tương tự thế này

Code dưới gọn gàn hơn Code tôi gợi ý lúc trước
PHP: 
Function GetFileFullname(FolderPath As String, Optional sDesc As String = "Excel", _
                                             Optional sFilter As String = "*.xls") As Variant
  GetFileFullname = Array()
  Dim Arr(), k, it
  With Application.FileDialog(msoFileDialogOpen)
    .ButtonName = "&Open" 'Nút chỉ thị
    .initialFilename = FolderPath 'Đi đến đường dẫn cho trước
    '.Filters.Delete(1) '
    .Filters.Clear 'Xóa gợi ý các loại tệp mở rộng
    .Filters.Add sDesc, sFilter 'Bắt đầu thêm lại Gợi ý - Mặc định
    .Filters.Add "All File", "*.*" 'Thêm 1 Gợi ý nữa
    .Title = "File Open" 'Tiêu đề
    .InitialView = msoFileDialogViewDetails 'Kiểu sắp xếp để xem
    .AllowMultiSelect = True 'Cho phép chọn nhiều tệp
    If .show = -1 Then
      For Each it In .SelectedItems
        ReDim Preserve Arr(k): Arr(k) = it
        k = k + 1
      Next it
      GetFileFullname = Arr
    End If
  End With
End Function
Nhấp chuột vào đây để mở rộng...

Xin chào @HeSanbi,
Đúng là vấn đề lấy dữ liệu từ nguồn chưa xác định rõ cụ thể đường dẫn và tên file OT đã nhiều va chạm đến , nhưng lần nào gặp phải trường hợp lựa chọn file trong số file đã chọn để lấy dữ liệu như trường hợp này.
Cảm ơn HeSanbi các code trong bài viết.
OT sẽ cố gắng tìm hiểu ạ.
----------------------
huuthang_bd đã viết:
Nếu đã có điều kiện cho mỗi file (đặc điểm nhận dạng cho từng loại file A và B) thì lọc luôn khi chọn - tức là chỉ hiển thị các file hợp lệ để chọn. Đồng thời, khi chọn xong thì kiểm tra luôn có phải đã chọn 1 file dạng A và 1 file dạng B không, nếu không phải thì yêu cầu chọn lại chứ đừng để cho chọn rồi rồi lại bảo chọn không đúng.
Bạn xem code và dữ liệu mẫu trong file đính kèm.
Nhấp chuột vào đây để mở rộng...

Xin chào huuthang_bd,
Code của anh và file anh đính kèm đúng với mong muốn của OT rồi ạ. OT sẽ phát triển thêm theo ý mình.
OT cảm ơn anh Hữu Thắng nhiều ạ.
 
Upvote 0
Mã: 
Private Sub Worksheet_Change(ByVal Target As Range)
     Dim a As Long, lr As Long, i As Long, j As Byte
     Dim arr, arr1
     If Target.Address = "$C$1" Then
       With Sheet1
         lr = .Range("B" & Rows.Count).End(xlUp).Row
         If lr < 3 Then MsgBox "khong co du lieu": Exit Sub
         arr = .Range("A3:E" & lr).Value
         ReDim arr1(1 To UBound(arr, 1), 1 To 5)
         For i = 1 To UBound(arr, 1)
             If arr(i, 1) = Target.Value Then
                a = a + 1
                For j = 1 To 5
                    arr1(a, j) = arr(i, j)
                Next j
             End If
         Next i
       End With
       With Sheet2
            lr = .Range("B" & Rows.Count).End(xlUp).Row
            If lr > 2 Then .Range("a3:e" & lr).ClearContents
            If a Then .Range("A3").Resize(a, 5).Value = arr1
       End With
     End If
End Sub

a/c GIÚP EM DỊCH CÁI CODE NÀY VỚI , MÌNH KHÔNG HIỂU CHỔ 2 HÀM FOR LỒNG VÀO NHAU !!!
 
Upvote 0
Mã: 
         For i = 1 To UBound(arr, 1)
1             If arr(i, 1) = Target.Value Then
                a = a + 1
3               For j = 1 To 5
                    arr1(a, j) = arr(i, j)
  5              Next j
             End If
         Next i
a/c GIÚP EM DỊCH CÁI CODE NÀY VỚI , MÌNH KHÔNG HIỂU CHỔ 2 HÀM FOR LỒNG VÀO NHAU !!!
Nhấp chuột vào đây để mở rộng...
Vòng lặp ngoài (theo tham biến i) duyệt từ đầu đến cuối mảng (dữ liệu)
D1: (Nếu dòng đang duyệt) thỏa điều kiện thì thực hiện các lệnh trước D6
D2: Tăng biến đềm a lên 1 đơn vị
D3: Tạo vòng lặp theo cột (1 -> 5)
D4 Ghi 5 giá trị ứng với 5 cột của dòng dữ liệu (thỏa Đ/K) vô mảng đích (Arr1())

Vui nếu giúp bạn ít nhiều
 
Lần chỉnh sửa cuối:
Upvote 0
Nhờ các thầy cô xem giúp em file đính kèm ạ. File đính em em cũng đang dùng code sẵn rồi. Nhưng lại chưa đúng ý lắm.
Các thầy cô có thể giúp em viết code. Hoặc tư vấn em nên dùng hàm gì trong excel để đáp ứng được các yêu cầu trong đó ạ.
Em cám ơn
Formmau
 
Upvote 0
buiquangthuan đã viết:
Nhờ các thầy cô xem giúp em file đính kèm ạ. File đính em em cũng đang dùng code sẵn rồi. Nhưng lại chưa đúng ý lắm.
Các thầy cô có thể giúp em viết code. Hoặc tư vấn em nên dùng hàm gì trong excel để đáp ứng được các yêu cầu trong đó ạ.
Em cám ơn
Formmau
Nhấp chuột vào đây để mở rộng...
Bấm vào Link của bạn nó ra cái này
1545918324237.png​
Nếu không phải là gải thích, gỡ rối về Code Bạn lập Topic mới sẽ có nhiều người tư vấn cho Bạn
 
Upvote 0

File đính kèm

Upvote 0
. . . . (1) File đính em cũng đang dùng code sẵn rồi. Nhưng lại chưa đúng ý lắm.
(2) Các thầy cô có thể giúp em viết code. Hoặc tư vấn em nên dùng hàm gì trong excel để đáp ứng được các yêu cầu trong đó ạ.
Nhấp chuột vào đây để mở rộng...
(1) Trong file không thấy miếng Code nào cả, nên chưa thể biết ý bạn là sao?
(2) Trong file có mỗi trang dữ liệu; Các dữ liệu thuộc 31 dòng & trãi dài từ cột A đến cột G, TRong đó công thức tại 2 cột E & G đang lỗi
Nên không rõ iêu cầu của bạn là gì.

Tạm biết!
 
Lần chỉnh sửa cuối:
Upvote 0
Xin chào các bạn.
Oanh Thơ tạo 1 hàm tìm kiếm địa chỉ của 1 chuỗi ký tự như sau:
Mã: 
Function MyFind(txtFind As String, rng As Range) As Range
    If Not IsError(Application.Match(txtFind, rng, 0)) Then
         Set MyFind = Cells(Application.Match(txtFind, rng, 0), 1)
         Debug.Print MyFind.Address
    End If
End Function
Nhờ các bạn giúp đỡ làm thế nào để gán được địa chỉ của chuỗi cần tìm vào biến "txtAddress" khi chạy testMyFind:
Mã: 
Sub testMyFind()
    Dim rngtxt As Range, txtAddress As Range
    Set rngtxt = ThisWorkbook.Worksheets("Sheet1").Range("A1:A" & 10000)
    MyFind "NguyenHoangOanhTho", rngtxt
End Sub
 
Upvote 0
Nguyễn Hoàng Oanh Thơ đã viết:
Xin chào các bạn.
Oanh Thơ tạo 1 hàm tìm kiếm địa chỉ của 1 chuỗi ký tự như sau:
Mã: 
Function MyFind(txtFind As String, rng As Range) As Range
    If Not IsError(Application.Match(txtFind, rng, 0)) Then
         Set MyFind = Cells(Application.Match(txtFind, rng, 0), 1)
         Debug.Print MyFind.Address
    End If
End Function
Nhờ các bạn giúp đỡ làm thế nào để gán được địa chỉ của chuỗi cần tìm vào biến "txtAddress" khi chạy testMyFind:
Mã: 
Sub testMyFind()
    Dim rngtxt As Range, txtAddress As Range
    Set rngtxt = ThisWorkbook.Worksheets("Sheet1").Range("A1:A" & 10000)
    MyFind "NguyenHoangOanhTho", rngtxt
End Sub
Nhấp chuột vào đây để mở rộng...
Cái này thì gán bình thường thôi mà.
Mã: 
Set  txtAddress = MyFind("NguyenHoangOanhTho", rngtxt)
 
Upvote 0
Nguyễn Hoàng Oanh Thơ đã viết:
Xin chào các bạn.
Oanh Thơ tạo 1 hàm tìm kiếm địa chỉ của 1 chuỗi ký tự như sau:
Mã: 
Function MyFind(txtFind As String, rng As Range) As Range
    If Not IsError(Application.Match(txtFind, rng, 0)) Then
         Set MyFind = Cells(Application.Match(txtFind, rng, 0), 1)
         Debug.Print MyFind.Address
    End If
End Function
Nhờ các bạn giúp đỡ làm thế nào để gán được địa chỉ của chuỗi cần tìm vào biến "txtAddress" khi chạy testMyFind:
Mã: 
Sub testMyFind()
    Dim rngtxt As Range, txtAddress As Range
    Set rngtxt = ThisWorkbook.Worksheets("Sheet1").Range("A1:A" & 10000)
    MyFind "NguyenHoangOanhTho", rngtxt
End Sub
Nhấp chuột vào đây để mở rộng...
Kết quả hàm MyFind là cái gì vậy bạn? Tôi chưa hình dung được áp dụng vào việc gì.
 
Lần chỉnh sửa cuối:
Upvote 0
O. Thơ cần tạo 1 hàm tìm kiếm địa chỉ của 1 chuỗi ký tự
Nhấp chuột vào đây để mở rộng...
Hình như bạn này đang cần tìm kiếm trên cột [A:A] 1 chuỗi kí tự nhập vô từ bàn fím
Nếu tìm thấy thì liệt kê địa chỉ ô được tìm thấy?

Nếu vấy thì thực hiện trong 1 macro thôi, gồm các công đoạn sau:

Nhấp kí tự cần tìm vô 1 tham biến (kiểu chuỗi) bằng hàm InputBox()
Tới đây có thể có chí ít các trường hợp như sau:
1./ Không tìm thấy: Trả lời "Nothing"
2./ Tìm thấy chỉ có 1 ô: Trả vế địa chỉ ô đó
3./ Tìm thấy từ 2 ô trở lên:
Khai báo từ đầu 1 mảng ghi kết quả của công cuộc tìm kiếm đó
Trả về là dẫy địa chỉ các ô được tìm thấy.

Ngoài ra cũng nói trước là: Công cuộc tìm kiếm này có fải tìm nguyên thể hay chỉ tìm gần đúng,
Ví dụ tìm mọi người có họ là 'Nguyễn' hay họ & đệm là 'Nguyễn Văn',. . . . (?)
Tìm chữ hoa lẫn chữ thường, chuỗi thể hiện ngày-tháng
Trị cầm tìm là kiểu số, như 2019
Trị cần tìm là thể loại 'Ngày-Tháng-Năm',. . . .

Dù gì thì cũng không nhất thiết fải viết hàm
Vì fương thức FIND() sẽ chỉ tìm 1 lần duy nhất, ta không thu kết quả của FinNext() (Kết quả của FindNext chỉ thấy trên cửa số Immediate mà thôi.)
. . . . . .
Mong fản hồi từ bạn & chúc vui khi sắp sang xuân!
 
Upvote 0
Xin cảm ơn chú @giaiphap ,anh @huuthang_bd ,bác @SA_DQ nhiều ạ.

OT sử dụng hàm MyFind với mục đích tìm 1 chuỗi trong một vùng dữ liệu bao gồm các ô gộp(trộn) ạ, vì phương thức find không tìm kiếm được với các ô bị trộn(gộp).
Mới đầu OT cũng viết như chú @giaiphap rồi nhưng chắc do viết sai lỗi chính tả trong code nên báo lỗi đỏ, loay hoay mãi không được nên gửi lên GPE để hỏi ạ.
Cảm ơn bác @SA_DQ cháu đã xử lý được vấn đề với hàm MyFind rồi ạ.
Kính chúc Bác/Chú/Anh năm mới nhiều sức khỏe.
Oanh Thơ
 
Upvote 0
OT sử dụng hàm MyFind với mục đích tìm 1 chuỗi trong một vùng dữ liệu bao gồm các ô gộp(trộn) ạ, vì phương thức find không tìm kiếm được với các ô bị trộn(gộp).
Nhấp chuột vào đây để mở rộng...
Trong các hàm UDF thì mình sẽ thử, nhưng FIND() vẫn có thể tìm trong các ô trộn như thường (trong macro); Chỉ là fải xài với tí chút mẹo
Ví dụ tìm trong cột dữ liệu có các ô trộn theo:
Cột, có nghĩa là vài 3 ô trong cột bị trộn lại thì ta fải tăng vùng tìm kiếm lên theo hàng (dòng), ví dụ từ 99 hàng lên 120 hàng chẵng hạn
Hàng, có nghĩa là vài hàng nào đó trong cột đã bị trộn ô theo hàng thì vùng tìm kiếm cần tăng số cột lên thêm chục hay hơn số cột.

Còn trong UDF, mình xin nhắc lại là FINDNext chỉ cho ta kết quả trên cửa số Immediate mà thôi.
 
Upvote 0
SA_DQ đã viết:
Trong các hàm UDF thì mình sẽ thử, nhưng FIND() vẫn có thể tìm trong các ô trộn như thường (trong macro); Chỉ là fải xài với tí chút mẹo
Ví dụ tìm trong cột dữ liệu có các ô trộn theo:
Cột, có nghĩa là vài 3 ô trong cột bị trộn lại thì ta fải tăng vùng tìm kiếm lên theo hàng (dòng), ví dụ từ 99 hàng lên 120 hàng chẵng hạn
Hàng, có nghĩa là vài hàng nào đó trong cột đã bị trộn ô theo hàng thì vùng tìm kiếm cần tăng số cột lên thêm chục hay hơn số cột.

Còn trong UDF, mình xin nhắc lại là FINDNext chỉ cho ta kết quả trên cửa số Immediate mà thôi.
Nhấp chuột vào đây để mở rộng...

Cháu cảm ơn bác Sa,
Nghĩa là mở rộng vùng tìm kiếm so với vùng chứa dữ liệu thì vẫn sử dụng được phương thức Find ạ.
Thảo nào khi cháu thao tác thủ công crtl+F vẫn tìm được với các ô trộn nhưng khi chạy code trong vùng có dữ liệu thì không được, cháu sẽ thử lại ạ.
 
Upvote 0
Tôi cũng có lúc nghĩ nhầm. Cứ đổ tôi cho ghép ô nhưng không phải 100% là như vậy.

Giả sử ta tìm trong cột I, nhưng Ik:Nk, Im:Nm, Ip:Np, với k, m, q là các số nguyên dương nào đó, là các ô ghép (tức tìm trong cột nhưng các ô được ghép theo dòng chứ không phải theo cột đang tìm kiếm) thì
Mã: 
Set rng = ThisWorkbook.Worksheets("DL").Range("I1:I" & Rows.Count).Find(Target.Value, , xlValues, xlWhole, xlByColumns, xlNext)
sẽ trả về rng = Nothing.

Nhưng
Mã: 
Set rng = ThisWorkbook.Worksheets("DL").Range("I1:I" & Rows.Count - 1).Find(Target.Value, , xlValues, xlWhole, xlByColumns, xlNext)

sẽ trả về ô merge trong cột I mà có giá trị Target.Value

Tóm lại sự khác nhau chỉ là Rows.Count - 1 thay cho Rows.Count. Hoặc không dùng Rows.Count mà tìm dòng cuối có dữ liệu bằng End(xlUp)

Tóm lại không bắt buộc phải mở rộng (tìm dòng cuối có dữ liệu bằng End(xlUp) rồi FIND trong vùng đó thôi). Còn nếu lười không xác định vùng dữ liệu mà chỉ dùng mở rộng thì không được mở rộng tới Rows.Count. Chỉ mở rộng cùng lắm tới Rows.Count-1
 
Lần chỉnh sửa cuối:
Upvote 0
Con cảm ơn bác Siwtom về những chỉ dẫn rất chi tiết ạ.
Vấn đề tìm kiếm với ô ghép con cũng đã xử lý được ngay tức thời rồi ạ,trước khi tìm thì hủy merge là được. Có chút cảm hứng nên con tìm hiểu để biết thêm về cách viết hàm và lấy giá trị của hàm ạ.
Con chúc bác sức khỏe.
Oanh Thơ.
 
Upvote 0
Nguyễn Hoàng Oanh Thơ đã viết:
Con cảm ơn bác Siwtom về những chỉ dẫn rất chi tiết ạ.
Vấn đề tìm kiếm với ô ghép con cũng đã xử lý được ngay tức thời rồi ạ,trước khi tìm thì hủy merge là được. Có chút cảm hứng nên con tìm hiểu để biết thêm về cách viết hàm và lấy giá trị của hàm ạ.
Con chúc bác sức khỏe.
Oanh Thơ.
Nhấp chuột vào đây để mở rộng...
Thì tôi cũng chỉ muốn lưu ý là không cần hủy merge.
Nếu tôi viết
Mã: 
Set rng = ThisWorkbook.Worksheets("DL").Range("I1:I" & Rows.Count).Find(Target.Value, , xlValues, xlWhole, xlByColumns, xlNext)
mà FIND không tìm thấy, tức rng là Nothing, thì không bắt buộc phải hủy merge mà chỉ cần sửa thành Rows.Count-1 hoặc thay Rows.Count bằng lastRow, với lastRow được xác định bằng End(xlUp). Tôi chỉ muốn nhấn mạnh là có lúc tôi tưởng phải bỏ merge nhưng thực ra tôi lầm.

Còn về cái bạn hỏi trong chủ đề này thì đơn giản thôi. Hàm của bạn trả về 1 đối tượng, ở đây là đối tượng Range. Với đối tượng thì bạn phải dùng từ khóa SET
Mã: 
Set txtAddress = MyFind("NguyenHoangOanhTho", rngtxt)

Tất nhiên txtAddress là cái tên không đúng vì nó là đối tượng Range chứ không phải giá trị String (address)
 
Upvote 0
batman1 đã viết:
Thì tôi cũng chỉ muốn lưu ý là không cần hủy merge.
Nếu tôi viết
Mã: 
Set rng = ThisWorkbook.Worksheets("DL").Range("I1:I" & Rows.Count).Find(Target.Value, , xlValues, xlWhole, xlByColumns, xlNext)
mà FIND không tìm thấy, tức rng là Nothing, thì không bắt buộc phải hủy merge mà chỉ cần sửa thành Rows.Count-1 hoặc thay Rows.Count bằng lastRow, với lastRow được xác định bằng End(xlUp). Tôi chỉ muốn nhấn mạnh là có lúc tôi tưởng phải bỏ merge nhưng thực ra tôi lầm.

Còn về cái bạn hỏi trong chủ đề này thì đơn giản thôi. Hàm của bạn trả về 1 đối tượng, ở đây là đối tượng Range. Với đối tượng thì bạn phải dùng từ khóa SET
Mã: 
Set txtAddress = MyFind("NguyenHoangOanhTho", rngtxt)

Tất nhiên txtAddress là cái tên không đúng vì nó là đối tượng Range chứ không phải giá trị String (address)
Nhấp chuột vào đây để mở rộng...

Dạ vâng,con hiểu rồi.Con cảm ơn bác nhiều ạ.
 
Upvote 0
PHP: 
Option Explicit
Sub SendMail()
    Dim OutApp As Object
    Dim OutMail As Object
    Dim cell As Range
    Dim i As Long
    Dim Addresslist As Object
    Application.ScreenUpdating = False
    Set Addresslist = CreateObject("Scripting.Dictionary")

    Set OutApp = CreateObject("Outlook.Application")
    OutApp.Session.Logon
   
    For Each cell In Columns("C").Cells.SpecialCells(xlCellTypeConstants)
        If cell.Value Like "?*@?*.?*" And LCase(Cells(cell.Row, "F").Value) = "y" Then
                Set OutMail = OutApp.CreateItem(0)
                With OutMail
                    .Attachments.Add Cells(2, 5) & cell.Offset(0, 2) & ".xlsx"
                    .To = cell.Value
                    .Subject = Cells(cell.Row, "I").Value
                    .Body = Cells(cell.Row, "D").Value
                    .Send  'Or use Send us Display
                End With
                Set OutMail = Nothing
        End If
    Next cell

    Set OutApp = Nothing
    Set Addresslist = Nothing
    Application.ScreenUpdating = True
   
    MsgBox "Game over"
   
End Sub

Cho em hỏi làm thế nào để em chèn thêm chữ ký khi gửi mail hàng loạt (Tên chữ ký mặc định trong outlook em đặt là "Ky chung")
 
Upvote 0
tueyennhi đã viết:
PHP: 
Option Explicit
Sub SendMail()
    Dim OutApp As Object
    Dim OutMail As Object
    Dim cell As Range
    Dim i As Long
    Dim Addresslist As Object
    Application.ScreenUpdating = False
    Set Addresslist = CreateObject("Scripting.Dictionary")

    Set OutApp = CreateObject("Outlook.Application")
    OutApp.Session.Logon
  
    For Each cell In Columns("C").Cells.SpecialCells(xlCellTypeConstants)
        If cell.Value Like "?*@?*.?*" And LCase(Cells(cell.Row, "F").Value) = "y" Then
                Set OutMail = OutApp.CreateItem(0)
                With OutMail
                    .Attachments.Add Cells(2, 5) & cell.Offset(0, 2) & ".xlsx"
                    .To = cell.Value
                    .Subject = Cells(cell.Row, "I").Value
                    .Body = Cells(cell.Row, "D").Value
                    .Send  'Or use Send us Display
                End With
                Set OutMail = Nothing
        End If
    Next cell

    Set OutApp = Nothing
    Set Addresslist = Nothing
    Application.ScreenUpdating = True
  
    MsgBox "Game over"
  
End Sub

Cho em hỏi làm thế nào để em chèn thêm chữ ký khi gửi mail hàng loạt (Tên chữ ký mặc định trong outlook em đặt là "Ky chung")
Nhấp chuột vào đây để mở rộng...
Bạn xóa cái code body đi.
Hoặc là bạn tạo chữ ký trong cells rồi gọi vào.
 
Upvote 0
tueyennhi đã viết:
PHP: 
Option Explicit
Sub SendMail()
    Dim OutApp As Object
    Dim OutMail As Object
    Dim cell As Range
    Dim i As Long
    Dim Addresslist As Object
    Application.ScreenUpdating = False
    Set Addresslist = CreateObject("Scripting.Dictionary")

    Set OutApp = CreateObject("Outlook.Application")
    OutApp.Session.Logon
  
    For Each cell In Columns("C").Cells.SpecialCells(xlCellTypeConstants)
        If cell.Value Like "?*@?*.?*" And LCase(Cells(cell.Row, "F").Value) = "y" Then
                Set OutMail = OutApp.CreateItem(0)
                With OutMail
                    .Attachments.Add Cells(2, 5) & cell.Offset(0, 2) & ".xlsx"
                    .To = cell.Value
                    .Subject = Cells(cell.Row, "I").Value
                    .Body = Cells(cell.Row, "D").Value
                    .Send  'Or use Send us Display
                End With
                Set OutMail = Nothing
        End If
    Next cell

    Set OutApp = Nothing
    Set Addresslist = Nothing
    Application.ScreenUpdating = True
  
    MsgBox "Game over"
  
End Sub

Cho em hỏi làm thế nào để em chèn thêm chữ ký khi gửi mail hàng loạt (Tên chữ ký mặc định trong outlook em đặt là "Ky chung")
Nhấp chuột vào đây để mở rộng...
Bạn thêm 1 dòng
PHP: 
With OutMail
    .open
    ...
end with
 
Upvote 0
Ví dụ em có mảng với dữ liệu giờ như sau: 1/8/2019 8:00:39 PM
Vậy làm thế nào để chuyển đổi nó thành 1/8/2019 8:00:00 PM (chuyển số giây thành 0 hết) một cách đơn giản và tối ưu nhất?
 
Upvote 0
CDate(Format(duLieuNgayGio, "dd-mmm-yyyy hh:mm")) ' chặt bỏ phần giây phía sau
Application.Round(duLieuNgayGio * 1440, 0) / 1440 ' làm tròn đến số phút
 
Upvote 0
phong cách sql :)
Mã: 
DateAdd("n", DateDiff("n", 0, "1/8/2019 8:00:39 PM"), 0)
 
Upvote 0
VetMini đã viết:
CDate(Format(duLieuNgayGio, "dd-mmm-yyyy hh:mm")) ' chặt bỏ phần giây phía sau
Application.Round(duLieuNgayGio * 1440, 0) / 1440 ' làm tròn đến số phút
Nhấp chuột vào đây để mở rộng...
Cảm ơn anh! :)

Em thử nghiệm với một Range thì kết quả ra đúng ý em muốn. Nhưng khi lắp vào mảng nó không chạy.
Vao = CDate(Format(Arr(j, 3), "mmm/dd/yyyy hh:mm"))
Em phải viết lại như này thì chạy ngon lành
- Vao = Arr(j, 3)
- Vao = CDate(Format(Vao, "mmm/dd/yyyy hh:mm"))

Vì sao lại như vậy anh nhỉ?
Bài đã được tự động gộp:

AutoReply đã viết:
phong cách sql :)
Mã: 
DateAdd("n", DateDiff("n", 0, "1/8/2019 8:00:39 PM"), 0)
Nhấp chuột vào đây để mở rộng...
Cảm ơn bạn nhé!
 
Lần chỉnh sửa cuối:
Upvote 0
BÁC NÀO DỊCH DÙM EM NGUYÊN ĐOẠN CODE NÀY VỚI :


Mã: 
Sub fifo()
  Dim nhapArr(), xuatArr(), Res()
  Dim I As Long, n As Long, sRow As Long
  Dim sNhap As Double, sXuat As Double, dXuat As Date
  Dim Ma As String, tmp As String
  With Sheets("DATABB")
    I = .Range("A" & Rows.Count).End(xlUp).Row
    If I < 3 Then MsgBox ("Khong co du lieu"): Exit Sub
    nhapArr = .Range("A3:D" & I).Value
    I = .Range("F" & Rows.Count).End(xlUp).Row
    If I < 3 Then MsgBox ("Khong co du lieu"): Exit Sub
    xuatArr = .Range("F3:H" & I).Value
    sRow = UBound(xuatArr)
    ReDim Res(1 To sRow, 1 To 1)
  End With
  For I = 1 To sRow
    dXuat = xuatArr(I, 1): Ma = xuatArr(I, 2): sXuat = xuatArr(I, 3)
    tmp = ""
    If Len(Ma) > 0 And sXuat > 0 Then
      For n = 1 To UBound(nhapArr)
        If nhapArr(n, 1) > dXuat Then Exit For
        If nhapArr(n, 2) = Ma Then
          sNhap = nhapArr(n, 3)
          If sNhap > 0 Then
            If sNhap >= sXuat Then
              Res(I, 1) = tmp & nhapArr(n, 4)
              If Len(tmp) > 0 Then Res(I, 1) = Res(I, 1) & "(" & sXuat & ")"
              nhapArr(n, 3) = sNhap - sXuat
              sXuat = 0
              Exit For
            Else
              tmp = tmp & nhapArr(n, 4) & "(" & sNhap & "); "
              nhapArr(n, 3) = 0
              sXuat = sXuat - sNhap
            End If
          End If
        End If
      Next n
      If sXuat > 0 Then Res(I, 1) = tmp & "Thieu(" & sXuat & ")"
    End If
  Next I
  Sheets("DATABB").Range("I3").Resize(sRow) = Res
End Sub
 
Upvote 0
guitarnguyen1989 đã viết:
BÁC NÀO DỊCH DÙM EM NGUYÊN ĐOẠN CODE NÀY VỚI :


Mã: 
Sub fifo()
  Dim nhapArr(), xuatArr(), Res()
  Dim I As Long, n As Long, sRow As Long
  Dim sNhap As Double, sXuat As Double, dXuat As Date
  Dim Ma As String, tmp As String
  With Sheets("DATABB")
    I = .Range("A" & Rows.Count).End(xlUp).Row
    If I < 3 Then MsgBox ("Khong co du lieu"): Exit Sub
    nhapArr = .Range("A3:D" & I).Value
    I = .Range("F" & Rows.Count).End(xlUp).Row
    If I < 3 Then MsgBox ("Khong co du lieu"): Exit Sub
    xuatArr = .Range("F3:H" & I).Value
    sRow = UBound(xuatArr)
    ReDim Res(1 To sRow, 1 To 1)
  End With
  For I = 1 To sRow
    dXuat = xuatArr(I, 1): Ma = xuatArr(I, 2): sXuat = xuatArr(I, 3)
    tmp = ""
    If Len(Ma) > 0 And sXuat > 0 Then
      For n = 1 To UBound(nhapArr)
        If nhapArr(n, 1) > dXuat Then Exit For
        If nhapArr(n, 2) = Ma Then
          sNhap = nhapArr(n, 3)
          If sNhap > 0 Then
            If sNhap >= sXuat Then
              Res(I, 1) = tmp & nhapArr(n, 4)
              If Len(tmp) > 0 Then Res(I, 1) = Res(I, 1) & "(" & sXuat & ")"
              nhapArr(n, 3) = sNhap - sXuat
              sXuat = 0
              Exit For
            Else
              tmp = tmp & nhapArr(n, 4) & "(" & sNhap & "); "
              nhapArr(n, 3) = 0
              sXuat = sXuat - sNhap
            End If
          End If
        End If
      Next n
      If sXuat > 0 Then Res(I, 1) = tmp & "Thieu(" & sXuat & ")"
    End If
  Next I
  Sheets("DATABB").Range("I3").Resize(sRow) = Res
End Sub
Nhấp chuột vào đây để mở rộng...
Bạn muốn ghi chú sao không dùng phím F8.Chạy từng đoạn code.
 
Upvote 0
Chào mọi người.
Mọi người có thể giúp e code để xác định tên của User Form đang hiển thị được không ạ.
Ví dụ khi mình chuyển qua file khác thì ẩn form, và quay lại file đó thì hiện form lên.
Xin cám ơn !
 
Upvote 0
befaint đã viết:
Cuối cùng là mình muốn làm cái chi chi? Nói vậy hiểu răng được.
Nhấp chuột vào đây để mở rộng...
dễ hiểu mà. nghĩa là e tạo 1 userform sẽ hiển thị khi bật file đó lên.
và khi chuyển qua làm việc trên file khác thì userform đó sẽ tự động ẩn. và khi quay lại thì hiện lại form đó.
nữa là có code nào để xác định tên của user form đang load được không.? dạng như kiểu " activesheet.name " vậy á :d
 
Upvote 0
Sub Boimau()
Sheets("UU").Select
Range("N11:O38").Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorLight2
.TintAndShade = 0.799981688894314
.PatternTintAndShade = 0
End With
Sheets("YE").Select
Range("N11:O38").Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorLight2
.TintAndShade = 0.799981688894314
.PatternTintAndShade = 0
End With
Sheets("YG").Select
Range("N11:O38").Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorLight2
.TintAndShade = 0.799981688894314
.PatternTintAndShade = 0
End With
Sheets("YH").Select
Range("N11:O38").Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorLight2
.TintAndShade = 0.799981688894314
.PatternTintAndShade = 0
End With
Sheets("YJ").Select
Range("N11:O38").Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorLight2
.TintAndShade = 0.799981688894314
.PatternTintAndShade = 0
End With
Sheets("YN").Select
Range("N11:O38").Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorLight2
.TintAndShade = 0.799981688894314
.PatternTintAndShade = 0
End With
Sheets("YQ").Select
Range("N11:O38").Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorLight2
.TintAndShade = 0.799981688894314
.PatternTintAndShade = 0
End With
Sheets("YP").Select
Range("N11:O38").Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorLight2
.TintAndShade = 0.799981688894314
.PatternTintAndShade = 0
End With
Sheets("YR").Select
Range("N11:O38").Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorLight2
.TintAndShade = 0.799981688894314
.PatternTintAndShade = 0
End With
Sheets("YS").Select
Range("N11:O38").Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorLight2
.TintAndShade = 0.799981688894314
.PatternTintAndShade = 0
End With
Sheets("YT").Select
Range("N11:O38").Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorLight2
.TintAndShade = 0.799981688894314
.PatternTintAndShade = 0
End With
Sheets("QQ").Select
Range("N11:O38").Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorLight2
.TintAndShade = 0.799981688894314
.PatternTintAndShade = 0
End With
Sheets("NN").Select
Range("N11:O38").Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorLight2
.TintAndShade = 0.799981688894314
.PatternTintAndShade = 0
End With
Sheets("PP").Select
Range("N11:O38").Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorLight2
.TintAndShade = 0.799981688894314
.PatternTintAndShade = 0
End With
Sheets("VV").Select
Range("N11:O38").Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorLight2
.TintAndShade = 0.799981688894314
.PatternTintAndShade = 0
End With
Sheets("SS").Select
Range("N11:O38").Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorLight2
.TintAndShade = 0.799981688894314
.PatternTintAndShade = 0
End With
Sheets("TT").Select
Range("N11:O38").Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorLight2
.TintAndShade = 0.799981688894314
.PatternTintAndShade = 0
End With
Sheets("RR").Select
Range("N11:O38").Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorLight2
.TintAndShade = 0.799981688894314
.PatternTintAndShade = 0
End With
Sheets("QQ").Select
End Sub
Nhấp chuột vào đây để mở rộng...
Nhờ các thầy cô rút ngẵn đoạn code giúp em được không ạ
 
Upvote 0
buiquangthuan đã viết:
Nhờ các thầy cô rút ngẵn đoạn code giúp em được không ạ
Nhấp chuột vào đây để mở rộng...
Chạy thử xem sao
Mã: 
Sub Boimau_()
Dim Ten
Dim Ws As Worksheet
Dim IDic As Object
Dim t
Set IDic = CreateObject("Scripting.Dictionary")
Ten = Array("UU", "YE", "YG", "YH", "YJ", "YN", "YQ", "YP", "YR", "YS", "YT", "QQ", "NN", "PP", "VV", "SS", "TT", "RR", "QQ")
For Each t In Ten
    IDic.Item(t) = ""
Next t
For Each Ws In Worksheets
    If IDic.exists(Ws.Name) Then
        Ws.Range("N11:O38").Select
        With Selection.Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .ThemeColor = xlThemeColorLight2
        .TintAndShade = 0.799981688894314
        .PatternTintAndShade = 0
        End With
    End If
Next Ws
End Sub
 
Upvote 0
CHAOQUAY đã viết:
Chạy thử xem sao
Mã: 
Sub Boimau_()
Dim Ten
Dim Ws As Worksheet
Dim IDic As Object
Dim t
Set IDic = CreateObject("Scripting.Dictionary")
Ten = Array("UU", "YE", "YG", "YH", "YJ", "YN", "YQ", "YP", "YR", "YS", "YT", "QQ", "NN", "PP", "VV", "SS", "TT", "RR", "QQ")
For Each t In Ten
    IDic.Item(t) = ""
Next t
For Each Ws In Worksheets
    If IDic.exists(Ws.Name) Then
        Ws.Range("N11:O38").Select
        With Selection.Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .ThemeColor = xlThemeColorLight2
        .TintAndShade = 0.799981688894314
        .PatternTintAndShade = 0
        End With
    End If
Next Ws
End Sub
Nhấp chuột vào đây để mở rộng...
Nó báo lỗi thầy ơi
 

File đính kèm

  • anh1.png
    anh1.png
    178.7 KB · Đọc: 4
Upvote 0
PHP: 
Sub GPE(Rng As Range)
 With Rng.Interior
    .Pattern = xlSolid:                                 .PatternColorIndex = xlAutomatic
    .ThemeColor = xlThemeColorLight2:     .TintAndShade = 0.799981688894314
    .PatternTintAndShade = 0
 End With
End Sub
Mã: 
Sub Boimau()
 Sheets("UU").Select
 Range("N11:O38").Select:           GPE Selection
 Sheets("YE").Select
 Range("N11:O38").Select:            GPE Selection
 Sheets("YG").Select
 Range("N11:O38").Select:            GPE Selection
 Sheets("YH").Select
 Range("N11:O38").Select:            GPE Selection
 Sheets("YJ").Select
 Range("N11:O38").Select:            GPE Selection
 Sheets("YN").Select
 Range("N11:O38").Select:            GPE Selection
 Sheets("YQ").Select
 Range("N11:O38").Select:            GPE Selection
 Sheets("YP").Select
 Range("N11:O38").Select:            GPE Selection
 Sheets("YR").Select
 Range("N11:O38").Select:            GPE Selection
 Sheets("YS").Select
 Range("N11:O38").Select:            GPE Selection
 Sheets("YT").Select
 Range("N11:O38").Select:            GPE Selection
 Sheets("QQ").Select
 Range("N11:O38").Select:            GPE Selection
 Sheets("NN").Select
 Range("N11:O38").Select:            GPE Selection
 Sheets("PP").Select
 Range("N11:O38").Select:            GPE Selection
 Sheets("VV").Select
 Range("N11:O38").Select:            GPE Selection
 Sheets("SS").Select
 Range("N11:O38").Select:            GPE Selection
 Sheets("TT").Select
 Range("N11:O38").Select:            GPE Selection
 Sheets("RR").Select
 Range("N11:O38").Select:            GPE Selection
 Sheets("QQ").Select
 End Sub
 
Upvote 0
SA_DQ đã viết:
PHP: 
Sub GPE(Rng As Range)
With Rng.Interior
    .Pattern = xlSolid:                                 .PatternColorIndex = xlAutomatic
    .ThemeColor = xlThemeColorLight2:     .TintAndShade = 0.799981688894314
    .PatternTintAndShade = 0
End With
End Sub
Mã: 
Sub Boimau()
Sheets("UU").Select
Range("N11:O38").Select:           GPE Selection
Sheets("YE").Select
Range("N11:O38").Select:            GPE Selection
Sheets("YG").Select
Range("N11:O38").Select:            GPE Selection
Sheets("YH").Select
Range("N11:O38").Select:            GPE Selection
Sheets("YJ").Select
Range("N11:O38").Select:            GPE Selection
Sheets("YN").Select
Range("N11:O38").Select:            GPE Selection
Sheets("YQ").Select
Range("N11:O38").Select:            GPE Selection
Sheets("YP").Select
Range("N11:O38").Select:            GPE Selection
Sheets("YR").Select
Range("N11:O38").Select:            GPE Selection
Sheets("YS").Select
Range("N11:O38").Select:            GPE Selection
Sheets("YT").Select
Range("N11:O38").Select:            GPE Selection
Sheets("QQ").Select
Range("N11:O38").Select:            GPE Selection
Sheets("NN").Select
Range("N11:O38").Select:            GPE Selection
Sheets("PP").Select
Range("N11:O38").Select:            GPE Selection
Sheets("VV").Select
Range("N11:O38").Select:            GPE Selection
Sheets("SS").Select
Range("N11:O38").Select:            GPE Selection
Sheets("TT").Select
Range("N11:O38").Select:            GPE Selection
Sheets("RR").Select
Range("N11:O38").Select:            GPE Selection
Sheets("QQ").Select
End Sub
Nhấp chuột vào đây để mở rộng...
Nó chạy lâu quá thầy ơi. Hay máy em cùi mía nhỉ
 
Upvote 0
Bạn phải đăng nhập hoặc đăng ký để trả lời bài viết tại đây.

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

D
in ra bị thiếu chữ (1 người xem)
Trả lời
3
Đọc
37
ptm0412
ptm0412
Momominh
Hỏi công thức tìm tuần thiếu hàng (1 người xem)
Trả lời
1
Đọc
40
hoangtuaotrang_hp_vn
H
2
EM MUỐN TẠO MA TRẬN BIẾN ĐỔI GIÁ TRỊ PHẦN TỬ NGẪU NHIÊN (1 người xem)
Trả lời
2
Đọc
31
ptm0412
ptm0412
V
  • Question Question
Tạo dữ liệu random cho từng sheet dựa theo dữ liệu có sẵn
Trả lời
2
Đọc
74
victoriabmt
V
Emyeuexcel
Cộng 4 tuần theo 1 qui luật qui định (1 người xem)
Trả lời
34
Đọc
2K
Emyeuexcel
Emyeuexcel
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
394
Đọc
46K
ThanhsonLC
T
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
Trả lời
24
Đọc
25K
dungpham01
D
Gà Con yêu VBA
Mở Pass file excel phiên bản .xlsx , xlsm, xlsb (2 người xem)
Trả lời
6
Đọc
276
YêuCN
Y
S
Mở 2 cửa sổ riêng biệt
Trả lời
31
Đọc
24K
ThanhNgan240723
T
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
7
Đọc
429
ongke0711
ongke0711
vn81206
TRA CỨU MÃ SỐ THUẾ CÁ NHÂN QUA EXCEL
    • Buồn
Trả lời
57
Đọc
20K
vovietdung261016
V
PhanTuHuong
CHỌN VÀ SỬ DỤNG MÁY LỌC KHÔNG KHÍ
    • Thích
    • Cảm ơn
Trả lời
7
Đọc
1K
PhanTuHuong
PhanTuHuong
huuthang_bd
Add in SwitchSheet: Quay lại các sheet đã xem trước đó bằng phím tắt (6 người xem)
    • Thích
    • Yêu thích
2
Trả lời
146
Đọc
42K
phong_codon
P
N
  • Question Question
Hỗ trợ tiếng việt trong macro
Trả lời
14
Đọc
596
Quang_Hải
Quang_Hải
N
Cài phần mềm đọc số ra chữ
Trả lời
2
Đọc
117
Nguyễn Duy Tuân
Nguyễn Duy Tuân
T
Em cần hỗ trợ tách nhiều file và đặt tên theo quy ước chung từ bảng 01 excel có sẳng
Trả lời
1
Đọc
102
HUONGHCKT
H
N
hàm đếm theo dòng
Trả lời
1
Đọc
89
dungpham01
D
H
LỖI KHOẢNG TRỐNG EXCEL DƯỚI THANH CÔNG CỤ
Trả lời
1
Đọc
63
ptm0412
ptm0412
A
  • Question Question
Share file copy dữ liệu từ tờ khai hải quan.
    • Thích
Trả lời
10
Đọc
991
anhdepjai
A
dungluyen2119
  • Question Question
Code VBA để tính tổng theo chiều ngang mà số cột không cố định
Trả lời
6
Đọc
324
le_vis
L
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