Chuyên đề giải đáp những thắc mắc về code VBA (3 người xem)

Liên hệ QC

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

Đang trực tuyến: 3 (Thành viên: 0, Khách: 3)
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
Em đang tạo đoạn code:
- In ra file PDF
- Tên file PDF là: Thong bao thanh toan
- Nơi lưu với đường dẫn D:\File dinh kem
(Mỗi lần in ra file PDF, đều đặt tên file là "Thong bao thanh toan", Đều lưu vào ổ D:\File dinh kem, Lưu các lần sau sẽ trùng tên thì được phép ghi đè lên file trước)

Hiện tại Em mới tạo được đoạn code hiển thị in như dưới đây. Em chưa đưa được vào đúng đường dẫn và đặt tên file rồi ghi đề lên tệp trước nếu trùng tên. Mong các tiền bối chỉ bảo. Tks nhiều!

Mã: 
Sub PrintPDF()
ThisWorkbook.Sheets(1).PrintOut preview = False
End Sub
 
Upvote 0
Chào mọi người. Hiện em có 1 file demo công việc muốn mọi người giúp đỡ để tăng tốc thời gian khi chạy code update ở sheet Backupdata .Thay đổi năm và tháng, dữ liệu dựa vào file Holiday - OT.
 

File đính kèm

Upvote 0
Em đang tập viết code theo trên mạng.
Có một số chỗ em thử chỉnh sửa. Nhưng đều bị báo lỗi code.
(chi tiết em comment trong file excel VD Copy du lieu tu nhieu file khac nhau)

Em chưa hiểu rõ mình sai cú pháp code ở điểm nào. Mong các bác chỉ giáo và comment luôn lí do hộ em trong file excel cũng được.
=================================================================
File em gồm có
1. VD Copy du lieu tu nhieu file khac nhau (file chứa Marco)
2. Khu vuc 3 (file nguồn copy dữ liệu)
 

File đính kèm

Upvote 0
Chào anh chị! Code dưới đây là ẩn dòng trống, và dãn dòng rộng ra khi thành phần ký đuôi không đủ trong 1 khổ A4 sẽ dãn dòng ra để sang trang. Code đang bị lỗi như hình dưới và có file đính kèm. Anh chị tải file kiểm tra sửa dùm em lỗi này ạ.

9999999.jpg
 

File đính kèm

Upvote 0
AnhThu-1976 đã viết:
Các anh chị có cách nào để code báo số lượng tìm được như hình không (phần khoanh tròn màu đỏ)
Em cảm ơn
Nhấp chuột vào đây để mở rộng...
Mình có thể dùng CountIf.
Mã: 
Dim lnTotalResult As Long, strFind As String
With Worksheets("Sheet1")
    lnTotalResult = WorksheetFunction.CountIf(.UsedRange.Cells, strFind)
End With
Bài đã được tự động gộp:

vova2209 đã viết:
Chào anh chị! Code dưới đây là ẩn dòng trống, và dãn dòng rộng ra khi thành phần ký đuôi không đủ trong 1 khổ A4 sẽ dãn dòng ra để sang trang. Code đang bị lỗi như hình dưới và có file đính kèm. Anh chị tải file kiểm tra sửa dùm em lỗi này ạ.

View attachment 242324
Nhấp chuột vào đây để mở rộng...
cái này: .PageSetup.PrintTitleRows chưa có giá trị
 
Lần chỉnh sửa cuối:
Upvote 0
thnghiachau đã viết:
Mình có thể dùng CountIf.
Mã: 
Dim lnTotalResult As Long, strFind As String
With Worksheets("Sheet1")
    lnTotalResult = WorksheetFunction.CountIf(.UsedRange.Cells, strFind)
End With
Bài đã được tự động gộp:


cái này: .PageSetup.PrintTitleRows chưa có giá trị
Nhấp chuột vào đây để mở rộng...
sửa như nào bạn giúp mình luôn với, đây là code nhờ các anh chị viết cho giờ tìm lại bài cũ lâu lắm rồi nên không thấy
 
Upvote 0
Sub Vlookup_nhieu_gia_tri()
n = Application.CountIf(Range("a1:a30"), [c1])
Set rng = Range("a1:a30").Find([c1])
If Not rng Is Nothing Then
For i = 1 To n
Range("d" & i) = rng.Offset(, 1).value
Set rng = Range("a1:a30").FindNext(rng)
Next i
End If
End Sub
Tôi có code vlookup trả về nhiều giá trị như này. (giá trị tìm kiểm ở ô C1, trong vùng A1:A30, trả về cột D , giá trị ở cột B tương ứng)
nhờ mọi người chuyển thành function giúp ạ. Cám ơn
 
Upvote 0
Duong.bach đã viết:
Sub Vlookup_nhieu_gia_tri()
n = Application.CountIf(Range("a1:a30"), [c1])
Set rng = Range("a1:a30").Find([c1])
If Not rng Is Nothing Then
For i = 1 To n
Range("d" & i) = rng.Offset(, 1).value
Set rng = Range("a1:a30").FindNext(rng)
Next i
End If
End Sub
Tôi có code vlookup trả về nhiều giá trị như này. (giá trị tìm kiểm ở ô C1, trong vùng A1:A30, trả về cột D , giá trị ở cột B tương ứng)
nhờ mọi người chuyển thành function giúp ạ. Cám ơn
Nhấp chuột vào đây để mở rộng...
Bạn tạo array (rng.Offset(, 1).value ) kết quả rồi gán vào tên function thôi
 
Upvote 0
Upvote 0
Duong.bach đã viết:
Bác giúp em cụ thể được không ạ
Nhấp chuột vào đây để mở rộng...
hàm của bạn tôi chỉnh lại :
Mã: 
Function Vlookup_nhieu_gia_tri(ByVal rngRangeFind As Range, ByVal vWhatFind As Variant, Optional iLookAt As Integer = 2)
Dim cllResultFind As Range, strFirstAddress As String, strResult As String
    If Not rngRangeFind Is Nothing Then
        With rngRangeFind
            'Find All In Cell => iLookAt=1, Find Part of Cell=> iLookAt=2
            Set cllResultFind = .Find(What:=vWhatFind, After:=.Cells(.Cells.Count), LookIn:=xlValues, LookAt:=iLookAt, _
                                      SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False)
            If cllResultFind Is Nothing Then
                Exit Function
            Else
                strFirstAddress = cllResultFind.Address
                Do
                    strResult = IIf(strResult <> "", strResult & "{|}", "") & cllResultFind.Value
                    Set cllResultFind = .FindNext(cllResultFind)
                Loop While Not cllResultFind Is Nothing And cllResultFind.Address <> strFirstAddress
            End If
        End With
    End If
    If strResult <> "" Then Vlookup_nhieu_gia_tri = Split(strResult, "{|}")
End Function
Sử dụng như sau:
Mã: 
Dim arrResultFind
    'Find All In Cell => iLookAt=1, Find Part of Cell=> iLookAt=2
    arrResultFind = Vlookup_nhieu_gia_tri(Sheet2.Range("A1:A30"), Sheet2.Range("C1").Value, 2) 'Tìm phần trong cell
    arrResultFind = Vlookup_nhieu_gia_tri(Sheet2.Range("A1:A30"), Sheet2.Range("C1").Value, 1) 'Tìm toàn bộ trong Cell
Bạn chú ý: nếu tìm chính xác toàn bộ giá trị trong cell thì iLookAt=1 , và nếu chỉ tìm một phần trong cell thì iLookAt=2
Ví dụ: tìm trong A1:A5 ở Sheet2 với giá trị ở ô C1 là "BA"
BBA
BBC
CAA
CBA
CCC
=> tìm chính xác toàn bộ trong Cell: Vlookup_nhieu_gia_tri(Sheet2.Range("A1:A5"), Sheet2.Range("C1").Value, 1) thì sẽ không có kết quả
=> tìm một phần trong Cell: Vlookup_nhieu_gia_tri(Sheet2.Range("A1:A5"), Sheet2.Range("C1").Value, 2) thì kết quả là 2 giá trị "BBA" và "CBA"
 
Lần chỉnh sửa cuối:
Upvote 0
Anh Chị giúp Em cách chỉ copy công thức, không copy định dạng với ạ, Mong A/C giúp đỡ.
Range("D5").Copy Range("D6:D" & i)
 
Upvote 0
Upvote 0
Upvote 0
Upvote 0
huuthang_bd đã viết:
Mã: 
Range("D6:D" & i).FormulaR1C1 = Range("D5").FormulaR1C1
Nhấp chuột vào đây để mở rộng...
snow25 đã viết:
Bạn sửa vậy xem sao.
Mã: 
Range("D6:D" & i).Formula = Range("D5").Formula
Nhấp chuột vào đây để mở rộng...
thnghiachau đã viết:
Mã: 
Range("D5").Copy
Range("D6:D" & i).PasteSpecial Operation:=xlPasteFormula
Nhấp chuột vào đây để mở rộng...

Dạ Em làm được rồi. Cảm ơn A/C rất nhiều!
 
Upvote 0
Xin cho hỏi GPE,
Mình có thể thay code sau:
Mã: 
Dim arrReMain() As Integer
    ReDim arrReMain(4 To iLastRow) As Integer
    For i = 4 To iLastRow
        arrReMain(i) = Sheet1.Range("E" & i).Value
    Next i
bằng phương cách nào khác mà mình không dùng vòng lặp For không ạ?
Em muốn giữ chỉ số trong arrRemain đi từ 4 tới iLastRow ạ.

Cám ơn GPE nhiều.
 
Upvote 0
Em đang tập tành code. Em muốn chọn dòng từ 12 đến dòng cuối (i). Nếu em thay i vào chỗ chữ đỏ số 30 thì lại bị lỗi. Mong Anh Chị chỉ giúp Em sửa thế nào để thay i được vào đó. Em cảm ơn A/C.
Sub Sort_Sh18()
Dim i As Long
i = Sheet18.Range("C" & Rows.Count).End(xlUp).Row
Sheet18.Rows("12:30").Select
End Sub
 
Upvote 0
Love GPE đã viết:
Em đang tập tành code. Em muốn chọn dòng từ 12 đến dòng cuối (i). Nếu em thay i vào chỗ chữ đỏ số 30 thì lại bị lỗi. Mong Anh Chị chỉ giúp Em sửa thế nào để thay i được vào đó. Em cảm ơn A/C.
Sub Sort_Sh18()
Dim i As Long
i = Sheet18.Range("C" & Rows.Count).End(xlUp).Row
Sheet18.Rows("12:30").Select
End Sub
Nhấp chuột vào đây để mở rộng...
Sheet18.Rows("12:" & i).Select
 
Upvote 0
thnghiachau đã viết:
Xin cho hỏi GPE,
Mình có thể thay code sau:
Mã: 
Dim arrReMain() As Integer
    ReDim arrReMain(4 To iLastRow) As Integer
    For i = 4 To iLastRow
        arrReMain(i) = Sheet1.Range("E" & i).Value
    Next i
bằng phương cách nào khác mà mình không dùng vòng lặp For không ạ?
Em muốn giữ chỉ số trong arrRemain đi từ 4 tới iLastRow ạ.

Cám ơn GPE nhiều.
Nhấp chuột vào đây để mở rộng...
Mã: 
  eRow = Sheet1.Range("E" & Rows.Count).End(xlUp).Row
  arrReMain = Application.Transpose(Sheet1.Range("E4:E" & eRow).Value)
  ReDim Preserve arrReMain(4 To eRow)
 
Upvote 0
thnghiachau đã viết:
Xin cho hỏi GPE,
Mình có thể thay code sau:
Mã: 
Dim arrReMain() As Integer
    ReDim arrReMain(4 To iLastRow) As Integer
    For i = 4 To iLastRow
        arrReMain(i) = Sheet1.Range("E" & i).Value
    Next i
bằng phương cách nào khác mà mình không dùng vòng lặp For không ạ?
Em muốn giữ chỉ số trong arrRemain đi từ 4 tới iLastRow ạ.

Cám ơn GPE nhiều.
Nhấp chuột vào đây để mở rộng...
Tại sao lại không muốn dùng For bạn? Nếu thực sự không muốn vậy thì dùng do ... loop
 
Upvote 0
Mã: 
Rows("2:" & i).Sort [B2], 1
Dòng code trên Em đang sort cho cột B. Em chưa sort được thêm các cột. Anh Chị có thể giúp Em cách sort thêm được cột C và D. Em cảm ơn!
 
Lần chỉnh sửa cuối:
Upvote 0
thnghiachau đã viết:
Dạ thầy coi lại cái https://www.giaiphapexcel.com/diendan/threads/chia-số-lượng-các-cỡ-theo-điều-kiện-để-đóng-thùng.151217/page-3 ở bài #48.
Em làm thế là do muốn trùng số hàng trong bản tính luôn ạ.
Nhấp chuột vào đây để mở rộng...
Cần gì phải trùng.
Mã: 
Dim arrReMain As Variant
    arrReMain = Sheet1.Range("E4:E" & iLastRow).Value
    'Khi sử dụng thì điều chỉnh chỉ số cho phù hợp thôi
    'Ví dụ code của bạn dùng arrReMain(i) thì bây giờ là arrReMain(i -3, 1)
 
Upvote 0
huuthang_bd đã viết:
Cần gì phải trùng.
Mã: 
Dim arrReMain As Variant
    arrReMain = Sheet1.Range("E4:E" & iLastRow).Value
    'Khi sử dụng thì điều chỉnh chỉ số cho phù hợp thôi
    'Ví dụ code của bạn dùng arrReMain(i) thì bây giờ là arrReMain(i -3, 1)
Nhấp chuột vào đây để mở rộng...
hic.. lúc đó phải nhớ ... không thì lại khổ, còn nếu trùng thì dễ hình dung và làm không phải suy nghĩ ... nhớ ... và chỉnh
 
Upvote 0
mọi người cho mình hỏi mình đang ở file excel A, và có 1 Addins (trong Addins có form "Userform1")
vậy code ở file A viết như thế nào để gọi Userform1.show lên được (ThisWorkBook của Addins mình đổi tên thành TWBook rồi)
 
Upvote 0
HieuCD đã viết:
Thử kiểm tra các GiaTri
Mã: 
  eRow = Sheet1.Range("E" & Rows.Count).End(xlUp).Row
  arrReMain = Application.Transpose(Sheet1.Range("E4:E" & eRow).Value)
  ReDim Preserve arrReMain(4 To eRow)
  for i=4 to eRow
      GiaTri=arrReMain(i)' kiem tra ket qua
  next i
Nhấp chuột vào đây để mở rộng...
Máy tôi bị lỗi ngay dòng ReDim.
 
Upvote 0
huuthang_bd đã viết:
Máy tôi bị lỗi ngay dòng ReDim.
Nhấp chuột vào đây để mở rộng...
thnghiachau đã viết:
dạ máy em cũng vậy....
Nhấp chuột vào đây để mở rộng...
Nhiều bài quá chắc mấy bạn bỏ qua. Đây là tôi viết ở bài #2.677
ReDim Preserve arrReMain(1 To erow - 3) nó mới chịu

Và tiện đây cũng hỏi lại bạn @thnghiachau, sao bạn không muốn dùng vòng lặp For...Next? Tôi có hỏi ở trên nhưng chắc bạn cũng không thấy.
 
Upvote 0
Maika8008 đã viết:
Và tiện đây cũng hỏi lại bạn @thnghiachau, sao bạn không muốn dùng vòng lặp For...Next? Tôi có hỏi ở trên nhưng chắc bạn cũng không thấy.
Nhấp chuột vào đây để mở rộng...
Dạ, mình thấy và mình trả lời cho bác @huuthang_bd ở bài #2680 ...
Và code cuối cùng OK là của Bác @HieuCD
Mã: 
Dim arrReMain
    iLastRow = Sheet1.Cells(Sheet1.Rows.Count, "A").End(xlUp).Row 
    arrReMain = Application.Transpose(Sheet1.Range("E4:E" & iLastRow).Value)
    ReDim Preserve arrReMain(4 To iLastRow)
 
Upvote 0
thnghiachau đã viết:
Dạ, mình thấy và mình trả lời cho bác @huuthang_bd ở bài #2680 ...
Và code cuối cùng OK là của Bác @HieuCD
Mã: 
Dim arrReMain
    iLastRow = Sheet1.Cells(Sheet1.Rows.Count, "A").End(xlUp).Row
    arrReMain = Application.Transpose(Sheet1.Range("E4:E" & iLastRow).Value)
    ReDim Preserve arrReMain(4 To iLastRow)
Nhấp chuột vào đây để mở rộng...
bài #2.680 trả lời cho tại sao là số 4. Còn bạn hỏi ngay từ đầu là có cách gì khác ngoài việc dùng vòng lặp For!
 
Upvote 0
Maika8008 đã viết:
Tại sao lại không muốn dùng For bạn? Nếu thực sự không muốn vậy thì dùng do ... loop
Nhấp chuột vào đây để mở rộng...
Xin lỗi ... ngàn lần xin lỗi anh... vi em chưa trả lời anh... mong anh rộng lòng tha thứ...
em không muốn dùng vòng lặp (For hay Loop, hay do-Until...) là vì em không muốn code tương tác nhiều trên sheet.
anh xem bài #2680, em có cái link tới bài mà em đã làm cho một bạn trên GPE này.
Trước kia em làm không dùng mảng, sau đó thầy @huuthang_bd nói làm thế thì code chậm nên em đã đổi dùng mảng và đúng là chạy nhanh hơn rất nhiều.
Và nhân tiện em có khúc code mà đã hỏi, nó là tương tác trực tiếp với sheet nhiều lần qua vòng lặp For nên tiện em hỏi luôn đó mà...
 
Upvote 0
Upvote 0
thnghiachau đã viết:
thế thì em botay... vì em chạy vèo vèo...
Nhấp chuột vào đây để mở rộng...
Đã kiểm tra lại và code đó chạy ok. Do lúc nãy cột A của tôi không có dữ liệu nên bị lỗi :).
thnghiachau đã viết:
Hic... có vấn đề nào khác ở đây mà bác @huuthang_bd muốn đề cập ở đây mà "chưa nói ra" không nhỉ....
Phải đưa vào mục "thắc mắc biết hỏi ai" thôi... """:::":\
Nhấp chuột vào đây để mở rộng...
Bạn muốn đề cập đến vấn đề gì? Bâng quơ vậy ai biết thế nào :|
 
Upvote 0
huuthang_bd đã viết:
Máy tôi vẫn lỗi.
Nhấp chuột vào đây để mở rộng...
Không có dữ liệu eRow<4 sẽ báo lổi
Mã: 
Sub XYZ()
  Dim arrReMain, eRow&, i&, GiaTri
 
  eRow = Sheet1.Range("E" & Rows.Count).End(xlUp).Row
  If eRow < 4 Then MsgBox ("Khong co du lieu"): Exit Sub
  arrReMain = Application.Transpose(Sheet1.Range("E4:E" & eRow).Value)
  ReDim Preserve arrReMain(4 To eRow)
  For i = 4 To eRow
      GiaTri = arrReMain(i) ' kiem tra ket qua
  Next i
End Sub
 
Upvote 0
thnghiachau đã viết:
Mã: 
Dim arrReMain
    iLastRow = Sheet1.Cells(Sheet1.Rows.Count, "A").End(xlUp).Row
    arrReMain = Application.Transpose(Sheet1.Range("E4:E" & iLastRow).Value)
    ReDim Preserve arrReMain(4 To iLastRow)
Nhấp chuột vào đây để mở rộng...
huuthang_bd đã viết:
Máy tôi vẫn lỗi.
Nhấp chuột vào đây để mở rộng...

Nếu dùng Dim arrReMain thì không lỗi

Dim arrReMain() thì bị lỗi out of range khi dùng ReDim Preserve arrReMain(4 To iLastRow),

nhưng dùng ReDim Preserve arrReMain(1 To iLastRow -3) thì lại không lỗi

""":::":\ _)()(-
 
Upvote 0
Mã: 
Sub Sort_Sh18()
Dim i As Long
i = Sheet18.Range("C" & Rows.Count).End(xlUp).Row
Rows("2:" & i).Sort [B2], 1
End Sub
Đoạn code trên Em đang sắp xếp dữ liệu với 1 cột (cột B). Anh Chị giúp Em có cách nào để sắp xếp thêm được cột C, D. Em cảm ơn!
 
Upvote 0
Love GPE đã viết:
Mã: 
Sub Sort_Sh18()
Dim i As Long
i = Sheet18.Range("C" & Rows.Count).End(xlUp).Row
Rows("2:" & i).Sort [B2], 1
End Sub
Đoạn code trên Em đang sắp xếp dữ liệu với 1 cột (cột B). Anh Chị giúp Em có cách nào để sắp xếp thêm được cột C, D. Em cảm ơn!
Nhấp chuột vào đây để mở rộng...
Range("B2:d" & i).Sort [B2], 1
 
Upvote 0
thnghiachau đã viết:
hàm của bạn tôi chỉnh lại :
Mã: 
Function Vlookup_nhieu_gia_tri(ByVal rngRangeFind As Range, ByVal vWhatFind As Variant, Optional iLookAt As Integer = 2)
Dim cllResultFind As Range, strFirstAddress As String, strResult As String
    If Not rngRangeFind Is Nothing Then
        With rngRangeFind
            'Find All In Cell => iLookAt=1, Find Part of Cell=> iLookAt=2
            Set cllResultFind = .Find(What:=vWhatFind, After:=.Cells(.Cells.Count), LookIn:=xlValues, LookAt:=iLookAt, _
                                      SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False)
            If cllResultFind Is Nothing Then
                Exit Function
            Else
                strFirstAddress = cllResultFind.Address
                Do
                    strResult = IIf(strResult <> "", strResult & "{|}", "") & cllResultFind.Value
                    Set cllResultFind = .FindNext(cllResultFind)
                Loop While Not cllResultFind Is Nothing And cllResultFind.Address <> strFirstAddress
            End If
        End With
    End If
    If strResult <> "" Then Vlookup_nhieu_gia_tri = Split(strResult, "{|}")
End Function
Sử dụng như sau:
Mã: 
Dim arrResultFind
    'Find All In Cell => iLookAt=1, Find Part of Cell=> iLookAt=2
    arrResultFind = Vlookup_nhieu_gia_tri(Sheet2.Range("A1:A30"), Sheet2.Range("C1").Value, 2) 'Tìm phần trong cell
    arrResultFind = Vlookup_nhieu_gia_tri(Sheet2.Range("A1:A30"), Sheet2.Range("C1").Value, 1) 'Tìm toàn bộ trong Cell
Bạn chú ý: nếu tìm chính xác toàn bộ giá trị trong cell thì iLookAt=1 , và nếu chỉ tìm một phần trong cell thì iLookAt=2
Ví dụ: tìm trong A1:A5 ở Sheet2 với giá trị ở ô C1 là "BA"
BBA
BBC
CAA
CBA
CCC
=> tìm chính xác toàn bộ trong Cell: Vlookup_nhieu_gia_tri(Sheet2.Range("A1:A5"), Sheet2.Range("C1").Value, 1) thì sẽ không có kết quả
=> tìm một phần trong Cell: Vlookup_nhieu_gia_tri(Sheet2.Range("A1:A5"), Sheet2.Range("C1").Value, 2) thì kết quả là 2 giá trị "BBA" và "CBA"
Nhấp chuột vào đây để mở rộng...
Cám ơn bác, em đã copy code vảo module, nhưng gõ lệnh trong excel lại ko ra được kết quả, em làm như này có gì sai ko ạ ?
 

File đính kèm

  • Untitled.png
    Untitled.png
    16.9 KB · Đọc: 7
Upvote 0
Maika8008 đã viết:
Nếu dùng Dim arrReMain thì không lỗi

Dim arrReMain() thì bị lỗi out of range khi dùng ReDim Preserve arrReMain(4 To iLastRow),

nhưng dùng ReDim Preserve arrReMain(1 To iLastRow -3) thì lại không lỗi

""":::":\ _)()(-
Nhấp chuột vào đây để mở rộng...
Sao bạn cứ lặp đi lặp lại mãi cái dòng code này vậy nhỉ.
Dòng code của bạn không lỗi nhưng nó hoàn toàn vô dụng. Và vì nó vô dụng nên không thể nào đáp ứng nhu cầu của người hỏi được.
 
Upvote 0
xuanquocxd đã viết:
chào các cao nhận ạ, e có sưu tầm được 1 file vba về lấy link trong thư mục ra excel. tuy nhiên kết quả mặt định gán về cột A. nhờ các cao nhân chỉnh sửa gán về cột H được không ạ.
Cảm ơn các ạnh nhiều, mong nhận được sự giúp đỡ ạ
------
Sub Hyper()
Dim xFSO As Object
Dim xFolder As Object
Dim xFile As Object
Dim xFiDialog As FileDialog
Dim xPath As String
Dim I As Integer
Set xFiDialog = Application.FileDialog(msoFileDialogFolderPicker)
If xFiDialog.Show = -1 Then
xPath = xFiDialog.SelectedItems(1)
End If
Set xFiDialog = Nothing
If xPath = "" Then Exit Sub
Set xFSO = CreateObject("Scripting.FileSystemObject")
Set xFolder = xFSO.GetFolder(xPath)
For Each xFile In xFolder.Files
I = I + 1
ActiveSheet.Hyperlinks.Add Cells(I, 1), xFile.Path, , , xFile.Name
Next
End Sub
-------
Nhấp chuột vào đây để mở rộng...
Sửa số 1 là A thành số cột bạn muốn 8 là H tại dòng ActiveSheet.Hyperlinks.Add Cells(I, 1), xFile.Path, , , xFile.Name
 
Upvote 0
xuanquocxd đã viết:
chào các cao nhận ạ, e có sưu tầm được 1 file vba về lấy link trong thư mục ra excel. tuy nhiên kết quả mặt định gán về cột A. nhờ các cao nhân chỉnh sửa gán về cột H được không ạ.
Cảm ơn các ạnh nhiều, mong nhận được sự giúp đỡ ạ
------
Sub Hyper()
Dim xFSO As Object
Dim xFolder As Object
Dim xFile As Object
Dim xFiDialog As FileDialog
Dim xPath As String
Dim I As Integer
Set xFiDialog = Application.FileDialog(msoFileDialogFolderPicker)
If xFiDialog.Show = -1 Then
xPath = xFiDialog.SelectedItems(1)
End If
Set xFiDialog = Nothing
If xPath = "" Then Exit Sub
Set xFSO = CreateObject("Scripting.FileSystemObject")
Set xFolder = xFSO.GetFolder(xPath)
For Each xFile In xFolder.Files
I = I + 1
ActiveSheet.Hyperlinks.Add Cells(I, 1), xFile.Path, , , xFile.Name
Next
End Sub
-------
Nhấp chuột vào đây để mở rộng...
bạn coi cái dòng này: ActiveSheet.Hyperlinks.Add Cells(I, 1), xFile.Path, , , xFile.Name
chỉnh lại cái in đậm theo bạn muốn
 
Upvote 0
Sửa thẳng thành chữ H luôn để sau này bạn có muốn sửa thì còn nhớ.
Rich (BB code): 
Sub Hyper()
    Dim xFSO As Object
    Dim xFolder As Object
    Dim xFile As Object
    Dim xFiDialog As FileDialog
    Dim xPath As String
    Dim I As Integer
    Set xFiDialog = Application.FileDialog(msoFileDialogFolderPicker)
    If xFiDialog.Show = -1 Then
        xPath = xFiDialog.SelectedItems(1)
    End If
    Set xFiDialog = Nothing
    If xPath = "" Then Exit Sub
    Set xFSO = CreateObject("Scripting.FileSystemObject")
    Set xFolder = xFSO.GetFolder(xPath)
    For Each xFile In xFolder.Files
        I = I + 1
        ActiveSheet.Hyperlinks.Add Cells(I, "H"), xFile.Path, , , xFile.Name
    Next
End Sub
 
Upvote 0
Em có đoạn code dưới đây. Em đang tập tành lấy tên khách hàng từ listbox vào textbox.
Hiện tại khi em gõ tên khách hàng vào textbox -> đã thấy khách hàng ở dưới listbox rồi. Nhưng em dùng phím mũi tên để di chuyển xuống listbox chọn khách hàng thì ko xuống được. Em đang thử để setfocus cho lisbox (chỗ chữ em tô đỏ ở dưới code) - thì chưa kịp gõ đến chữ thứ 2 thì nó đã chuyển xuống lisbox mất rồi.
Em mong muốn GPE giúp Em .... sau khi gõ tìm kiếm khách hàng ở textbox -> thấy khách hàng cần tìm thì bấm mũi tên xuống -> con trỏ chuột sẽ chuyển xuống listbox để chọn khách hàng -> Bấm enter thì khách hàng sẽ được chọn vào textbox. Mong GPE giúp đỡ Em với ạ. Cảm ơn GPE rất nhiều!



Private Sub LxB_KhachHang_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
If KeyAscii = vbKeyReturn Then
TxB_KhachHang.Value = LxB_KhachHang.Value
LxB_KhachHang.Height = 0
End If
End Sub

Private Sub TxB_KhachHang_change()
LxB_KhachHang.Clear
LxB_KhachHang.Visible = True
LxB_KhachHang.Height = 150
LxB_KhachHang.Width = 400
LxB_KhachHang.List = Filter(WorksheetFunction.Transpose(Range("Name_KhachHang")), TxB_KhachHang.Value, True, vbTextCompare)
LxB_KhachHang.SetFocus
End Sub
 
Lần chỉnh sửa cuối:
Upvote 0
Love GPE đã viết:
Em có đoạn code dưới đây. Em đang tập tành lấy tên khách hàng từ listbox vào textbox.
Hiện tại khi em gõ tên khách hàng vào textbox -> đã thấy khách hàng ở dưới listbox rồi. Nhưng em dùng phím mũi tên để di chuyển xuống listbox chọn khách hàng thì ko xuống được. Em đang thử để setfocus cho lisbox (chỗ chữ em tô đỏ ở dưới code) - thì chưa kịp gõ đến chữ thứ 2 thì nó đã chuyển xuống lisbox mất rồi.
Em mong muốn GPE giúp Em .... sau khi gõ tìm kiếm khách hàng ở textbox -> thấy khách hàng cần tìm thì bấm mũi tên xuống -> con trỏ chuột sẽ chuyển xuống listbox để chọn khách hàng -> Bấm enter thì khách hàng sẽ được chọn vào textbox. Mong GPE giúp đỡ Em với ạ. Cảm ơn GPE rất nhiều!
Nhấp chuột vào đây để mở rộng...
Câu lệnh setFocus để trong thủ tục KeyDown của textbox, Keycode = 40. Xuống listBox rồi nhấn enter thì cũng dùng thủ tục keyDown, KeyCode = 13
 
Upvote 0
ptm0412 đã viết:
Câu lệnh setFocus để trong thủ tục KeyDown của textbox, Keycode = 40. Xuống listBox rồi nhấn enter thì cũng dùng thủ tục keyDown, KeyCode = 13
Nhấp chuột vào đây để mở rộng...

Em cảm ơn Thầy ptm0412 rất nhiều! Em sửa lệnh như chỗ tô mầu xanh. Để setfocus trong thủ tục Keydown với điều kiện keycode = 40 thì setfocus xuống lisbox được rồi Thầy ạ.

Private Sub LxB_KhachHang_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
If KeyAscii = vbKeyReturn Then
TxB_KhachHang.Value = LxB_KhachHang.Value
LxB_KhachHang.Height = 0
End If
End Sub
Private Sub TxB_KhachHang_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
LxB_KhachHang.Clear
LxB_KhachHang.Visible = True
LxB_KhachHang.Height = 150
LxB_KhachHang.Width = 400
LxB_KhachHang.List = Filter(WorksheetFunction.Transpose(Range("Name_KhachHang")), TxB_KhachHang.Value, True, vbTextCompare)
If KeyCode = 40 Then
LxB_KhachHang.SetFocus
End If
End Sub
 
Upvote 0
Mọi người cho hỏi, trong sheet để ngăn sự kiện chạy thì mình dùng Application.EnableEvents = False, còn trong userform để ngăn sự kiện Textbox1_Change thì mình dùng lệnh nào ạ?
Để trong một số trường hợp mình gõ vào textbox1 đó thì lệnh Textbox1_Change ko thực thi nữa đó ạ?
Cảm ơn đã giải đáp!
 
Lần chỉnh sửa cuối:
Upvote 0
moihocvba đã viết:
Mọi người cho hỏi, trong sheet để ngăn sự kiện chạy thì mình dùng Application.EnableEvents = False, còn trong user để ngăn sự kiện Textbox1_Change thì mình dùng lệnh nào ạ?
Để trong một số trường hợp mình gõ vào textbox1 đó thì lệnh Textbox1_Change ko thực thi nữa đó ạ?
Cảm ơn đã giải đáp!
Nhấp chuột vào đây để mở rộng...
Hình như là không có thì phải...
Bạn tạo biến Public (vd: blEnableEvents chẳng hạn)
và đầu mỗi sự kển bạn kiểm tra biến này
If Not blblEnableEvents then exit sub
 
Upvote 0
moihocvba đã viết:
Mọi người cho hỏi, trong sheet để ngăn sự kiện chạy thì mình dùng Application.EnableEvents = False, còn trong userform để ngăn sự kiện Textbox1_Change thì mình dùng lệnh nào ạ?
Để trong một số trường hợp mình gõ vào textbox1 đó thì lệnh Textbox1_Change ko thực thi nữa đó ạ?
Cảm ơn đã giải đáp!
Nhấp chuột vào đây để mở rộng...

Thì bạn căn cứ vào cái màu đỏ đó mà đặt điều kiện ở đầu sub sự kiện Textbox1_Change chẳng hạn - để Exit sub, hay chạy code
 
Upvote 0
Nhờ mọi người giúp mình đoạn code tạo chữ ký dưới bảng pivottable với ạ
 

File đính kèm

Upvote 0
Nhờ mọi người hỗ trợ về code in hàng loạt (nội dung chi tiết trên file đính kèm).
1/ File code print ot có sheep mình cần in hàng loạt để gởi cho công nhân (code mình sưu tầm từ đây: file đính kèm file test_in)
Bên dưới là code để add sign for button trong file test_in. Mình đọc code mà do ko chuyên về VBA nên khi copy code để add vào file thì nó báo lỗi " If sotrang > 1 Then" và cũng không hiểu lắm. Bạn nào biết hướng dẫn giúp mình.
2/ Phần funtion để viết chuyển từ hàng xuống cột mình viết hoi bị thủ công, có bạn nào có công thức hay hơn hoặc cách hay hơn chỉ giúp mình luôn.
Thủ đức hoặc loanh quanh gần mình mời cà phê để được học hỏi thêm càng tốt ạ ^^
THanks,
Mã: 
Attribute VB_Name = "in_hang_loat"
Sub inhangloat()
Attribute inhangloat.VB_ProcData.VB_Invoke_Func = " \n14"
   
    Dim tinhtoan As Variant
    Dim manhinh As Boolean
    Dim rng, rng1, rng2 As Range
    Dim t1, t2, sh2, sh1, add_rng1 As String
    Dim sotrang, k As Integer
    Dim she As Sheets
   
    On Error GoTo thoat
    manhinh = Application.ScreenUpdating
   
    tinhtoan = Application.Calculation
    Application.Calculation = xlCalculationManual
    Application.Calculation = xlCalculationManual
   
    '---------------------
    Set rng1 = Application.InputBox("nhap vao dia chi output", Type:=8)
    If rng1.Count <> 1 Then
        MsgBox "chon sai so ô, chi duoc chon 1 ô"
        Exit Sub
    End If
   
    add_rng1 = rng1.Address
    '---------------------
   
    Set rng2 = Application.InputBox("nhap vao dia chi input", Type:=8)
    Application.ScreenUpdating = False
    sotrang = rng2.Count
    For Each rng In rng2
        If rng.EntireRow.Hidden = True Or rng.Text = "" Then
            sotrang = sotrang - 1
        End If
    Next
   
    '---------------------(1)
    'Mo 1 workbook moi
    t1 = ActiveWorkbook.Name
    sh1 = ActiveSheet.Name
    Sheets(sh1).Select
    Sheets(sh1).Copy
    t2 = ActiveWorkbook.Name
    sh2 = ActiveSheet.Name
    '---------------------(1)
   
   
    '---------------------(2)
    'tao ra cac sheet
    If sotrang > 1 Then
       For i = 1 To sotrang - 1
           Workbooks(t2).Sheets(sh2).Select
           Workbooks(t2).Sheets(sh2).Copy Before:=Sheets(sh2)
       Next
    End If
    '----------------------(2)
   
   
    '------------------------------(3)
    ' Lay gia tri tu rng2 thay vao cac sheet
    k = 0
    For Each rng In rng2
        If rng.EntireRow.Hidden = False And rng.Text <> "" Then
          k = k + 1
          Workbooks(t2).Sheets(k).Range(add_rng1).Value = rng.Value
        End If
    Next
   
    Application.Calculation = xlCalculationAutomatic
    '------------------------------(3)
   
    Application.ScreenUpdating = manhinh
   
    t = Application.Dialogs(xlDialogPrinterSetup).Show
    Workbooks(t2).PrintOut ActivePrinter:=t
   
    Workbooks(t2).Close False
   
thoat:
    Application.Calculation = tinhtoan
    Application.ScreenUpdating = manhinh
   
End Sub
 

File đính kèm

Lần chỉnh sửa cuối:
Upvote 0
Chào Anh Chị! em có 1 code ở trên mang về dãn dòng, khi kích sửa trực tiếp thì sẽ tự động co về vừa chữ. Anh Chị chỉnh lại hộ em khi tự động co về "Chiều cao dòng tối thiểu là 18"
Mã: 
Private Sub Worksheet_Change(ByVal Target As Range)
    Dim NewRwHt As Single
    Dim cWdth As Single, MrgeWdth As Single
    Dim c As Range, cc As Range
    Dim ma As Range
    ActiveSheet.DisplayPageBreaks = False

    With Target
        If .MergeCells And .WrapText Then
        Set c = Target.Cells(1, 1)
            cWdth = c.ColumnWidth
        Set ma = c.MergeArea
        For Each cc In ma.Cells
            MrgeWdth = MrgeWdth + cc.ColumnWidth
        Next
        Application.ScreenUpdating = False
            ma.MergeCells = False
            c.ColumnWidth = MrgeWdth
            c.EntireRow.AutoFit
            NewRwHt = c.RowHeight
            c.ColumnWidth = cWdth
            ma.MergeCells = True
            ma.RowHeight = NewRwHt
            cWdth = 0: MrgeWdth = 0
        Application.ScreenUpdating = True
        End If
    End With
End Sub
 
Upvote 0
vova2209 đã viết:
Chào Anh Chị! em có 1 code ở trên mang về dãn dòng, khi kích sửa trực tiếp thì sẽ tự động co về vừa chữ. Anh Chị chỉnh lại hộ em khi tự động co về "Chiều cao dòng tối thiểu là 18"
Mã: 
Private Sub Worksheet_Change(ByVal Target As Range)
    Dim NewRwHt As Single
    Dim cWdth As Single, MrgeWdth As Single
    Dim c As Range, cc As Range
    Dim ma As Range
    ActiveSheet.DisplayPageBreaks = False

    With Target
        If .MergeCells And .WrapText Then
        Set c = Target.Cells(1, 1)
            cWdth = c.ColumnWidth
        Set ma = c.MergeArea
        For Each cc In ma.Cells
            MrgeWdth = MrgeWdth + cc.ColumnWidth
        Next
        Application.ScreenUpdating = False
            ma.MergeCells = False
            c.ColumnWidth = MrgeWdth
            c.EntireRow.AutoFit
            NewRwHt = c.RowHeight
            c.ColumnWidth = cWdth
            ma.MergeCells = True
            ma.RowHeight = NewRwHt
            cWdth = 0: MrgeWdth = 0
        Application.ScreenUpdating = True
        End If
    End With
End Sub
Nhấp chuột vào đây để mở rộng...
thay
ma.RowHeight = NewRwHt
thành
ma.RowHeight = IIf(NewRwHt>=18,NewRwHt,18)
 
Upvote 0
Lần chỉnh sửa cuối:
Upvote 0
Khi em chạy code msit81_3 có lúc báo lỗi script out of range có lúc không? Quan trọng hơn nữa là khi chạy xong vẫn thấy thiếu phần của tiền EUR ah!
Mong mọi người chỉ giúp!
 

File đính kèm

Upvote 0
Các bạn cho hỏi có cách nào gán 1 macro vào cell A1 của sheet Menu không? để khi ta nhấn ô A1 thì nó chay code không?
(đã tìm trong Hyperlink nhưng không có đường link dẫn đến macro)
Cảm ơn các bạn nhiều!
 
Upvote 0
hoanglocphat đã viết:
Các bạn cho hỏi có cách nào gán 1 macro vào cell A1 của sheet Menu không? để khi ta nhấn ô A1 thì nó chay code không?
(đã tìm trong Hyperlink nhưng không có đường link dẫn đến macro)
Cảm ơn các bạn nhiều!
Nhấp chuột vào đây để mở rộng...
Dùng sự kiện trong sheets là được nhé bạn.Bạn lên
 
Upvote 0
Lequocvan đã viết:
Khi em chạy code msit81_3 có lúc báo lỗi script out of range có lúc không? Quan trọng hơn nữa là khi chạy xong vẫn thấy thiếu phần của tiền EUR ah!
Mong mọi người chỉ giúp!
Nhấp chuột vào đây để mở rộng...
Đây là đoạn code VBA, mà em mày mò mãi chưa ra ah
Sub msit81_3()
''Dung Dictionary tong hop theo DP_TypeCode
Sheets("msit81_DP").Select
Dim Dic As Object
Dim iRow As Long, I As Long
Dim Arr() As Variant, VungDuLieu As Variant
With Sheets("BaoCaoTheoMSIT81")
.Range("A7:AR45").ClearContents '''''''''''''''''''''''''''''Tu dong 7 den dong 45
End With
With Sheets("msit81_DP")
Set Dic = CreateObject("Scripting.Dictionary")
VungDuLieu = Range("A1", Range("A1").End(xlToRight).End(xlDown).Address).Value '65536 '1048576
ReDim Arr(1 To UBound(VungDuLieu, 1), 1 To 29)

For iRow = 1 To UBound(VungDuLieu, 1)
j = j + 1
If Not IsEmpty(VungDuLieu(iRow, 5)) And Not Dic.Exists(VungDuLieu(iRow, 5)) Then
I = I + 1
Dic.Add VungDuLieu(iRow, 5), I
Arr(I, 1) = VungDuLieu(iRow, 5) 'Arr(I,1): DPCode
If VungDuLieu(iRow, 10) = "USD" Then '''''''''''''''''''''''''voi loai tien USD
If VungDuLieu(iRow, 1) = "00" Then
Arr(I, 2) = VungDuLieu(iRow, 11)
ElseIf VungDuLieu(iRow, 1) = "03" Then
Arr(I, 5) = VungDuLieu(iRow, 11)
ElseIf VungDuLieu(iRow, 1) = "04" Then
Arr(I, 8) = VungDuLieu(iRow, 11)
ElseIf VungDuLieu(iRow, 1) = "07" Then
Arr(I, 11) = VungDuLieu(iRow, 11)
ElseIf VungDuLieu(iRow, 1) = "09" Then
Arr(I, 14) = VungDuLieu(iRow, 11)
ElseIf VungDuLieu(iRow, 1) = "10" Then
Arr(I, 17) = VungDuLieu(iRow, 11)
ElseIf VungDuLieu(iRow, 1) = " " Then
Arr(I, 20) = VungDuLieu(iRow, 11)
ElseIf VungDuLieu(iRow, 1) = "05" Then
Arr(I, 23) = VungDuLieu(iRow, 11)
ElseIf VungDuLieu(iRow, 1) = "01" Then
Arr(I, 26) = VungDuLieu(iRow, 11)
ElseIf VungDuLieu(iRow, 1) = "02" Then
Arr(I, 29) = VungDuLieu(iRow, 11)
ElseIf VungDuLieu(iRow, 1) = "06" Then
Arr(I, 32) = VungDuLieu(iRow, 11)
ElseIf VungDuLieu(iRow, 1) = "08" Then
Arr(I, 35) = VungDuLieu(iRow, 11)
End If
ElseIf VungDuLieu(iRow, 10) = "VND" Then
If VungDuLieu(iRow, 1) = "00" Then
Arr(I, 3) = VungDuLieu(iRow, 11)
ElseIf VungDuLieu(iRow, 1) = "03" Then
Arr(I, 6) = VungDuLieu(iRow, 11)
ElseIf VungDuLieu(iRow, 1) = "04" Then
Arr(I, 9) = VungDuLieu(iRow, 11)
ElseIf VungDuLieu(iRow, 1) = "07" Then
Arr(I, 12) = VungDuLieu(iRow, 11)
ElseIf VungDuLieu(iRow, 1) = "09" Then
Arr(I, 15) = VungDuLieu(iRow, 11)
ElseIf VungDuLieu(iRow, 1) = "10" Then
Arr(I, 18) = VungDuLieu(iRow, 11)
ElseIf VungDuLieu(iRow, 1) = " " Then
Arr(I, 21) = VungDuLieu(iRow, 11)
ElseIf VungDuLieu(iRow, 1) = "05" Then
Arr(I, 24) = VungDuLieu(iRow, 11)
ElseIf VungDuLieu(iRow, 1) = "01" Then
Arr(I, 27) = VungDuLieu(iRow, 11)
ElseIf VungDuLieu(iRow, 1) = "02" Then
Arr(I, 30) = VungDuLieu(iRow, 11)
ElseIf VungDuLieu(iRow, 1) = "06" Then
Arr(I, 33) = VungDuLieu(iRow, 11)
ElseIf VungDuLieu(iRow, 1) = "08" Then
Arr(I, 36) = VungDuLieu(iRow, 11)
End If
ElseIf VungDuLieu(iRow, 10) = "EUR" Then
If VungDuLieu(iRow, 1) = "00" Then
Arr(I, 4) = VungDuLieu(iRow, 11)
ElseIf VungDuLieu(iRow, 1) = "03" Then
Arr(I, 7) = VungDuLieu(iRow, 11)
ElseIf VungDuLieu(iRow, 1) = "04" Then
Arr(I, 10) = VungDuLieu(iRow, 11)
ElseIf VungDuLieu(iRow, 1) = "07" Then
Arr(I, 13) = VungDuLieu(iRow, 11)
ElseIf VungDuLieu(iRow, 1) = "09" Then
Arr(I, 16) = VungDuLieu(iRow, 11)
ElseIf VungDuLieu(iRow, 1) = "10" Then
Arr(I, 19) = VungDuLieu(iRow, 11)
ElseIf VungDuLieu(iRow, 1) = " " Then
Arr(I, 22) = VungDuLieu(iRow, 11)
ElseIf VungDuLieu(iRow, 1) = "05" Then
Arr(I, 25) = VungDuLieu(iRow, 11)
ElseIf VungDuLieu(iRow, 1) = "01" Then
Arr(I, 28) = VungDuLieu(iRow, 11)
ElseIf VungDuLieu(iRow, 1) = "02" Then
Arr(I, 31) = VungDuLieu(iRow, 11)
ElseIf VungDuLieu(iRow, 1) = "06" Then
Arr(I, 34) = VungDuLieu(iRow, 11)
ElseIf VungDuLieu(iRow, 1) = "08" Then
Arr(I, 37) = VungDuLieu(iRow, 11)
End If
End If
Else
If VungDuLieu(iRow, 10) = "USD" Then
If VungDuLieu(iRow, 1) = "00" Then
Arr(Dic.Item(VungDuLieu(iRow, 5)), 2) = Arr(Dic.Item(VungDuLieu(iRow, 5)), 2) + VungDuLieu(iRow, 11)
ElseIf VungDuLieu(iRow, 1) = "03" Then
Arr(Dic.Item(VungDuLieu(iRow, 5)), 5) = Arr(Dic.Item(VungDuLieu(iRow, 5)), 5) + VungDuLieu(iRow, 11)
ElseIf VungDuLieu(iRow, 1) = "04" Then
Arr(Dic.Item(VungDuLieu(iRow, 5)), 8) = Arr(Dic.Item(VungDuLieu(iRow, 5)), 8) + VungDuLieu(iRow, 11)
ElseIf VungDuLieu(iRow, 1) = "07" Then
Arr(Dic.Item(VungDuLieu(iRow, 5)), 11) = Arr(Dic.Item(VungDuLieu(iRow, 5)), 11) + VungDuLieu(iRow, 11)
ElseIf VungDuLieu(iRow, 1) = "09" Then
Arr(Dic.Item(VungDuLieu(iRow, 5)), 14) = Arr(Dic.Item(VungDuLieu(iRow, 5)), 14) + VungDuLieu(iRow, 11)
ElseIf VungDuLieu(iRow, 1) = "10" Then
Arr(Dic.Item(VungDuLieu(iRow, 5)), 17) = Arr(Dic.Item(VungDuLieu(iRow, 5)), 17) + VungDuLieu(iRow, 11)
ElseIf VungDuLieu(iRow, 1) = " " Then
Arr(Dic.Item(VungDuLieu(iRow, 5)), 20) = Arr(Dic.Item(VungDuLieu(iRow, 5)), 20) + VungDuLieu(iRow, 11)
ElseIf VungDuLieu(iRow, 1) = "05" Then
Arr(Dic.Item(VungDuLieu(iRow, 5)), 23) = Arr(Dic.Item(VungDuLieu(iRow, 5)), 23) + VungDuLieu(iRow, 11)
ElseIf VungDuLieu(iRow, 1) = "01" Then
Arr(Dic.Item(VungDuLieu(iRow, 5)), 26) = Arr(Dic.Item(VungDuLieu(iRow, 5)), 26) + VungDuLieu(iRow, 11)
ElseIf VungDuLieu(iRow, 1) = "02" Then
Arr(Dic.Item(VungDuLieu(iRow, 5)), 29) = Arr(Dic.Item(VungDuLieu(iRow, 5)), 29) + VungDuLieu(iRow, 11)
ElseIf VungDuLieu(iRow, 1) = "06" Then
Arr(Dic.Item(VungDuLieu(iRow, 5)), 32) = Arr(Dic.Item(VungDuLieu(iRow, 5)), 32) + VungDuLieu(iRow, 11)
ElseIf VungDuLieu(iRow, 1) = "08" Then
Arr(Dic.Item(VungDuLieu(iRow, 5)), 35) = Arr(Dic.Item(VungDuLieu(iRow, 5)), 35) + VungDuLieu(iRow, 11)
End If
ElseIf VungDuLieu(iRow, 10) = "VND" Then
If VungDuLieu(iRow, 1) = "00" Then
Arr(Dic.Item(VungDuLieu(iRow, 5)), 3) = Arr(Dic.Item(VungDuLieu(iRow, 5)), 3) + VungDuLieu(iRow, 11)
ElseIf VungDuLieu(iRow, 1) = "03" Then
Arr(Dic.Item(VungDuLieu(iRow, 5)), 6) = Arr(Dic.Item(VungDuLieu(iRow, 5)), 6) + VungDuLieu(iRow, 11)
ElseIf VungDuLieu(iRow, 1) = "04" Then
Arr(Dic.Item(VungDuLieu(iRow, 5)), 9) = Arr(Dic.Item(VungDuLieu(iRow, 5)), 9) + VungDuLieu(iRow, 11)
ElseIf VungDuLieu(iRow, 1) = "07" Then
Arr(Dic.Item(VungDuLieu(iRow, 5)), 12) = Arr(Dic.Item(VungDuLieu(iRow, 5)), 12) + VungDuLieu(iRow, 11)
ElseIf VungDuLieu(iRow, 1) = "09" Then
Arr(Dic.Item(VungDuLieu(iRow, 5)), 15) = Arr(Dic.Item(VungDuLieu(iRow, 5)), 15) + VungDuLieu(iRow, 11)
ElseIf VungDuLieu(iRow, 1) = "10" Then
Arr(Dic.Item(VungDuLieu(iRow, 5)), 18) = Arr(Dic.Item(VungDuLieu(iRow, 5)), 18) + VungDuLieu(iRow, 11)
ElseIf VungDuLieu(iRow, 1) = " " Then
Arr(Dic.Item(VungDuLieu(iRow, 5)), 21) = Arr(Dic.Item(VungDuLieu(iRow, 5)), 21) + VungDuLieu(iRow, 11)
ElseIf VungDuLieu(iRow, 1) = "05" Then
Arr(Dic.Item(VungDuLieu(iRow, 5)), 24) = Arr(Dic.Item(VungDuLieu(iRow, 5)), 24) + VungDuLieu(iRow, 11)
ElseIf VungDuLieu(iRow, 1) = "01" Then
Arr(Dic.Item(VungDuLieu(iRow, 5)), 27) = Arr(Dic.Item(VungDuLieu(iRow, 5)), 27) + VungDuLieu(iRow, 11)
ElseIf VungDuLieu(iRow, 1) = "02" Then
Arr(Dic.Item(VungDuLieu(iRow, 5)), 30) = Arr(Dic.Item(VungDuLieu(iRow, 5)), 30) + VungDuLieu(iRow, 11)
ElseIf VungDuLieu(iRow, 1) = "06" Then
Arr(Dic.Item(VungDuLieu(iRow, 5)), 33) = Arr(Dic.Item(VungDuLieu(iRow, 5)), 33) + VungDuLieu(iRow, 11)
ElseIf VungDuLieu(iRow, 1) = "08" Then
Arr(Dic.Item(VungDuLieu(iRow, 5)), 36) = Arr(Dic.Item(VungDuLieu(iRow, 5)), 36) + VungDuLieu(iRow, 11)
End If
ElseIf VungDuLieu(iRow, 10) = "EUR" Then
If VungDuLieu(iRow, 1) = "00" Then
Arr(Dic.Item(VungDuLieu(iRow, 5)), 4) = Arr(Dic.Item(VungDuLieu(iRow, 5)), 4) + VungDuLieu(iRow, 11)
ElseIf VungDuLieu(iRow, 1) = "03" Then
Arr(Dic.Item(VungDuLieu(iRow, 5)), 7) = Arr(Dic.Item(VungDuLieu(iRow, 5)), 7) + VungDuLieu(iRow, 11)
ElseIf VungDuLieu(iRow, 1) = "04" Then
Arr(Dic.Item(VungDuLieu(iRow, 5)), 10) = Arr(Dic.Item(VungDuLieu(iRow, 5)), 10) + VungDuLieu(iRow, 11)
ElseIf VungDuLieu(iRow, 1) = "07" Then
Arr(Dic.Item(VungDuLieu(iRow, 5)), 13) = Arr(Dic.Item(VungDuLieu(iRow, 5)), 13) + VungDuLieu(iRow, 11)
ElseIf VungDuLieu(iRow, 1) = "09" Then
Arr(Dic.Item(VungDuLieu(iRow, 5)), 16) = Arr(Dic.Item(VungDuLieu(iRow, 5)), 16) + VungDuLieu(iRow, 11)
ElseIf VungDuLieu(iRow, 1) = "10" Then
Arr(Dic.Item(VungDuLieu(iRow, 5)), 19) = Arr(Dic.Item(VungDuLieu(iRow, 5)), 19) + VungDuLieu(iRow, 11)
ElseIf VungDuLieu(iRow, 1) = " " Then
Arr(Dic.Item(VungDuLieu(iRow, 5)), 22) = Arr(Dic.Item(VungDuLieu(iRow, 5)), 22) + VungDuLieu(iRow, 11)
ElseIf VungDuLieu(iRow, 1) = "05" Then
Arr(Dic.Item(VungDuLieu(iRow, 5)), 25) = Arr(Dic.Item(VungDuLieu(iRow, 5)), 25) + VungDuLieu(iRow, 11)
ElseIf VungDuLieu(iRow, 1) = "01" Then
Arr(Dic.Item(VungDuLieu(iRow, 5)), 28) = Arr(Dic.Item(VungDuLieu(iRow, 5)), 28) + VungDuLieu(iRow, 11)
ElseIf VungDuLieu(iRow, 1) = "02" Then
Arr(Dic.Item(VungDuLieu(iRow, 5)), 31) = Arr(Dic.Item(VungDuLieu(iRow, 5)), 31) + VungDuLieu(iRow, 11)
ElseIf VungDuLieu(iRow, 1) = "06" Then
Arr(Dic.Item(VungDuLieu(iRow, 5)), 34) = Arr(Dic.Item(VungDuLieu(iRow, 5)), 34) + VungDuLieu(iRow, 11)
ElseIf VungDuLieu(iRow, 1) = "08" Then
Arr(Dic.Item(VungDuLieu(iRow, 5)), 37) = Arr(Dic.Item(VungDuLieu(iRow, 5)), 37) + VungDuLieu(iRow, 11)
End If
End If
End If
Next iRow
End With

Sheets("BaoCaoTheoMSIT81").Select
With Sheets("BaoCaoTheoMSIT81")
.Range("B9").Resize(I, 37).Value = Arr 'dong nay de xuat gtri mang Arr ra
.Range("C7").Value = "HoiSo-TienGui"
.Range("C7:E7").Merge
.Range("F7").Value = "PGD03-TienGui"
.Range("F7:H7").Merge
.Range("I7").Value = "PGD04-TienGui"
.Range("I7:K7").Merge
.Range("L7").Value = "PGD07-TienGui"
.Range("L7:N7").Merge
.Range("O7").Value = "PGD09-TienGui"
.Range("O7:Q7").Merge
.Range("R7").Value = "PGD10-TienGui"
.Range("R7:T7").Merge
.Range("U7").Value = "IB-TienGui"
.Range("U7:W7").Merge
.Range("X7").Value = "PGD05-TienGui"
.Range("X7:Z7").Merge
.Range("AA7").Value = "PGD01-TienGui"
.Range("AA7:AC7").Merge
.Range("AD7").Value = "PGD02-TienGui"
.Range("AD7:AF7").Merge
.Range("AG7").Value = "PGD06-TienGui"
.Range("AG7:AI7").Merge
.Range("AJ7").Value = "PGD08-TienGui"
.Range("AJ7:AL7").Merge
.Range("C9").Value = "USD"
.Range("D9").Value = "VND"
.Range("E9").Value = "EUR"
.Range("C9:E9").Copy
.Range("F9:AL9").Select
.Paste
.Range("A9").Value = "STT"
.Range("B9").Value = "DPcode"
End With
Application.CutCopyMode = False
Set Dic = Nothing

Sheets("BaoCaoTheoMSIT81").Range("A7:AL" & Cells(Rows.count, 2).End(xlUp).Row).Select
With Selection
.Borders(xlDiagonalDown).LineStyle = xlNone
.Borders(xlDiagonalUp).LineStyle = xlNone
.Borders(xlEdgeLeft).Weight = xlMedium
.Borders(xlEdgeTop).Weight = xlMedium
.Borders(xlEdgeBottom).Weight = xlMedium
.Borders(xlEdgeRight).Weight = xlMedium
.Borders(xlInsideVertical).Weight = xlThin
.Borders(xlInsideHorizontal).Weight = xlThin
End With

Sheets("BaoCaoTheoMSIT81").Range("B8:B" & Cells(Rows.count, 2).End(xlUp).Row).Select
With Selection
.ColumnWidth = 4.71
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.WrapText = True
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
End With

'Sap xep thu tu cot DPcode
DongCuoiCuaCot = Cells(Rows.count, 2).End(xlUp).Row
ActiveWorkbook.Worksheets("BaoCaoTheoMSIT81").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("BaoCaoTheoMSIT81").Sort.SortFields.Add key:=Range( _
"B9:B" & DongCuoiCuaCot), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
xlSortNormal
With ActiveWorkbook.Worksheets("BaoCaoTheoMSIT81").Sort
.SetRange Range("B9:AL" & DongCuoiCuaCot)
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With

Range("C10", Range("AL" & DongCuoiCuaCot)).Select
Selection.NumberFormat = "#,##0.00"

Columns("A:AL").AutoFit
Sheets("BaoCaoTheoMSIT81").Range("A8").Select
Application.CutCopyMode = False
End Sub
 
Upvote 0
Nhờ cao nhân giúp mình làm sao có thể chỉnh code để có thể add in hàng loạt file như file đính kèm.
Mọi người xem file đính kèm cho dễ hiểu ạ.
Mình cần in tất cả các CODE trong cột S;
Lấy cell O4 làm tiêu chuẩn đầu tiên cho giá trị nhập (thực ra là chọn cell nào cũng được), miễn có mã nhân viên = B1 để lấy đó làm giá trị đầu tiên. Nếu chạy từng mã như vậy thì IN hàng loạt ok nhưng quá tốn giấy nên mình muốn chạy một lúc 7 cột thì có cách nào để in được và không bị trùng mã khi lấy dữ liệu.

Thanks!
Mã: 
Sub inhangloat()
   
    Dim tinhtoan As Variant
    Dim manhinh As Boolean
    Dim rng, rng1, rng2 As Range
    Dim t1, t2, sh2, sh1, add_rng1 As String
    Dim sotrang, k, i, t As Integer
    Dim she As Sheets
   
    On Error GoTo thoat
    manhinh = Application.ScreenUpdating
   
    tinhtoan = Application.Calculation
    Application.Calculation = xlCalculationManual
    Application.Calculation = xlCalculationManual
   
    '---------------------
    Set rng1 = Application.InputBox("nhap vao dia chi output", Type:=8)
    If rng1.Count <> 1 Then
        MsgBox "chon sai so ô, chi duoc chon 1 ô"
        Exit Sub
    End If
   
    add_rng1 = rng1.Address
    '---------------------
   
    Set rng2 = Application.InputBox("nhap vao dia chi input", Type:=8)
    Application.ScreenUpdating = False
    sotrang = rng2.Count
    For Each rng In rng2
        If rng.EntireRow.Hidden = True Or rng.Text = "" Then
            sotrang = sotrang - 1
        End If
    Next
   
    '---------------------(1)
    'Mo 1 workbook moi
    t1 = ActiveWorkbook.Name
    sh1 = ActiveSheet.Name
    Sheets(sh1).Select
    Sheets(sh1).Copy
    t2 = ActiveWorkbook.Name
    sh2 = ActiveSheet.Name
    '---------------------(1)
   
   
    '---------------------(2)
    'tao ra cac sheet
    If sotrang > 1 Then
       For i = 1 To sotrang - 1
           Workbooks(t2).Sheets(sh2).Select
           Workbooks(t2).Sheets(sh2).Copy Before:=Sheets(sh2)
       Next
    End If
    '----------------------(2)
   
   
    '------------------------------(3)
    ' Lay gia tri tu rng2 thay vao cac sheet
    k = 0
    For Each rng In rng2
        If rng.EntireRow.Hidden = False And rng.Text <> "" Then
          k = k + 1
          Workbooks(t2).Sheets(k).Range(add_rng1).Value = rng.Value
        End If
    Next
   
    Application.Calculation = xlCalculationAutomatic
    '------------------------------(3)
   
    Application.ScreenUpdating = manhinh
   
    t = Application.Dialogs(xlDialogPrinterSetup).Show
    Workbooks(t2).PrintOut ActivePrinter:=t
   
    Workbooks(t2).Close False
   
thoat:
    Application.Calculation = tinhtoan
    Application.ScreenUpdating = manhinh
   
End Sub
 

File đính kèm

Lần chỉnh sửa cuối:
Upvote 0
Chào mọi người ạ
Để xóa một cell đang chọn thì chúng ta viết code như sau:
Mã: 
Sub Xoa()
ActiveCell.Select
Selection.ClearContents
End Sub
Vậy nếu đang chọn một vùng range bất kỳ và muốn xóa thì code như thế nào ạ (Range này có thể thay đổi)
Em cảm ơn
 
Upvote 0
Trên bàn phím có phím Delete đó bạn, bấm vô.
 
Upvote 0
Mọi người ơi xem dùm code này bị lỗi gì và nên xử lý thế nào. Đơn thuần là mình muốn cột 21 = cột 15 - cột 4
Mã: 
Sub Update_Data()
Dim sArr(), i As Long, j As Long, Dic As Object, ResignedList()
Set Dic = CreateObject("scripting.dictionary")
With Sheets("Resigned List")
   ResignedList = .Range("A6", .Range("A" & Rows.Count).End(3)).Resize(, 10).Value
End With
For i = 1 To UBound(ResignedList)
   If Not Dic.exists(ResignedList(i, 2)) Then
      Dic.Add ResignedList(i, 2), ResignedList(i, 7)
   Else
      MsgBox "Duplicate " & ResignedList(i, 2)
   End If
Next
With Sheets("Candidates")
   sArr = .Range("A7", .Range("A" & Rows.Count).End(3)).Resize(, 21).Value
   For i = 1 To UBound(sArr)
      For j = 1 To UBound(sArr, 2)
         sArr(i, j) = Application.Trim(sArr(i, j))
      Next
      If IsDate(sArr(i, 4)) Then
         sArr(i, 18) = MonthName(Month(sArr(i, 4)), True)
         sArr(i, 19) = Year(sArr(i, 4))
      End If
      If Dic.exists(sArr(i, 5)) Then
         sArr(i, 15) = Dic.Item(sArr(i, 5))
         sArr(i, 14) = "Resigned"
         If IsDate(sArr(i, 4)) Then
            sArr(i, 21) = sArr(i, 15) - sArr(i, 4)
            If sArr(i, 21) < 4 Then
               sArr(i, 20) = "A"
            ElseIf sArr(i, 21) < 8 Then
               sArr(i, 20) = "B"
            ElseIf sArr(i, 21) < 31 Then
               sArr(i, 20) = "C"
            ElseIf sArr(i, 21) > 30 Then
               sArr(i, 20) = "D"
            End If
         End If
      End If
   Next
   .[A7].Resize(UBound(sArr), UBound(sArr, 2)) = sArr
End With
End Sub
 

File đính kèm

Upvote 0
quanghai1969 đã viết:
Mọi người ơi xem dùm code này bị lỗi gì và nên xử lý thế nào. Đơn thuần là mình muốn cột 21 = cột 15 - cột 4
Mã: 
Sub Update_Data()
Dim sArr(), i As Long, j As Long, Dic As Object, ResignedList()
Set Dic = CreateObject("scripting.dictionary")
With Sheets("Resigned List")
   ResignedList = .Range("A6", .Range("A" & Rows.Count).End(3)).Resize(, 10).Value
End With
For i = 1 To UBound(ResignedList)
   If Not Dic.exists(ResignedList(i, 2)) Then
      Dic.Add ResignedList(i, 2), ResignedList(i, 7)
   Else
      MsgBox "Duplicate " & ResignedList(i, 2)
   End If
Next
With Sheets("Candidates")
   sArr = .Range("A7", .Range("A" & Rows.Count).End(3)).Resize(, 21).Value
   For i = 1 To UBound(sArr)
      For j = 1 To UBound(sArr, 2)
         sArr(i, j) = Application.Trim(sArr(i, j))
      Next
      If IsDate(sArr(i, 4)) Then
         sArr(i, 18) = MonthName(Month(sArr(i, 4)), True)
         sArr(i, 19) = Year(sArr(i, 4))
      End If
      If Dic.exists(sArr(i, 5)) Then
         sArr(i, 15) = Dic.Item(sArr(i, 5))
         sArr(i, 14) = "Resigned"
         If IsDate(sArr(i, 4)) Then
            sArr(i, 21) = sArr(i, 15) - sArr(i, 4)
            If sArr(i, 21) < 4 Then
               sArr(i, 20) = "A"
            ElseIf sArr(i, 21) < 8 Then
               sArr(i, 20) = "B"
            ElseIf sArr(i, 21) < 31 Then
               sArr(i, 20) = "C"
            ElseIf sArr(i, 21) > 30 Then
               sArr(i, 20) = "D"
            End If
         End If
      End If
   Next
   .[A7].Resize(UBound(sArr), UBound(sArr, 2)) = sArr
End With
End Sub
Nhấp chuột vào đây để mở rộng...
Ai lại cắt vô tội vạ như thế :D
Rich (BB code): 
      For j = 1 To UBound(sArr, 2)
        If TypeName(sArr(i, j)) = "String" Then sArr(i, j) = Application.Trim(sArr(i, j))
      Next
 
Upvote 0
quanghai1969 đã viết:
Mọi người ơi xem dùm code này bị lỗi gì và nên xử lý thế nào. Đơn thuần là mình muốn cột 21 = cột 15 - cột 4
Mã: 
Sub Update_Data()
Dim sArr(), i As Long, j As Long, Dic As Object, ResignedList()
Set Dic = CreateObject("scripting.dictionary")
With Sheets("Resigned List")
   ResignedList = .Range("A6", .Range("A" & Rows.Count).End(3)).Resize(, 10).Value
End With
For i = 1 To UBound(ResignedList)
   If Not Dic.exists(ResignedList(i, 2)) Then
      Dic.Add ResignedList(i, 2), ResignedList(i, 7)
   Else
      MsgBox "Duplicate " & ResignedList(i, 2)
   End If
Next
With Sheets("Candidates")
   sArr = .Range("A7", .Range("A" & Rows.Count).End(3)).Resize(, 21).Value
   For i = 1 To UBound(sArr)
      For j = 1 To UBound(sArr, 2)
         sArr(i, j) = Application.Trim(sArr(i, j))
      Next
      If IsDate(sArr(i, 4)) Then
         sArr(i, 18) = MonthName(Month(sArr(i, 4)), True)
         sArr(i, 19) = Year(sArr(i, 4))
      End If
      If Dic.exists(sArr(i, 5)) Then
         sArr(i, 15) = Dic.Item(sArr(i, 5))
         sArr(i, 14) = "Resigned"
         If IsDate(sArr(i, 4)) Then
            sArr(i, 21) = sArr(i, 15) - sArr(i, 4)
            If sArr(i, 21) < 4 Then
               sArr(i, 20) = "A"
            ElseIf sArr(i, 21) < 8 Then
               sArr(i, 20) = "B"
            ElseIf sArr(i, 21) < 31 Then
               sArr(i, 20) = "C"
            ElseIf sArr(i, 21) > 30 Then
               sArr(i, 20) = "D"
            End If
         End If
      End If
   Next
   .[A7].Resize(UBound(sArr), UBound(sArr, 2)) = sArr
End With
End Sub
Nhấp chuột vào đây để mở rộng...
Em chỉnh lại thành sArr(i, 21) = CDate(sArr(i, 15)) - CDate(sArr(i, 4)) thì thấy hết lỗi, không biết đúng không nữa anh ơi
 
Upvote 0
thnghiachau đã viết:
Em chỉnh lại thành sArr(i, 21) = CDate(sArr(i, 15)) - CDate(sArr(i, 4)) thì thấy hết lỗi, không biết đúng không nữa anh ơi
Nhấp chuột vào đây để mở rộng...
Mình cũng test đủ kiểu, CDate, rồi cả DateValue cũng không ăn thua. Nó hết lỗi nhưng kết quả ra không đúng. Tại dòng đầu nó cứ cho kết quả là Aug
 
Upvote 0
huuthang_bd đã viết:
Ai lại cắt vô tội vạ như thế :D
Rich (BB code): 
      For j = 1 To UBound(sArr, 2)
        If TypeName(sArr(i, j)) = "String" Then sArr(i, j) = Application.Trim(sArr(i, j))
      Next
Nhấp chuột vào đây để mở rộng...
À giờ mình hiểu rồi. Sau khi trim thì dữ liệu ngày giờ sẽ bị chuyển sang Text.

Cảm ơn sự giải đáp của HuuThang, đã cho mình một kiến thức mới
 
Upvote 0
quanghai1969 đã viết:
Mình cũng test đủ kiểu, CDate, rồi cả DateValue cũng không ăn thua. Nó hết lỗi nhưng kết quả ra không đúng. Tại dòng đầu nó cứ cho kết quả là Aug
Nhấp chuột vào đây để mở rộng...
Em đoán là cái hàm Cdate nó quy đổi về ngày tháng năm không đúng.Anh dùng hàm này theo thủ công chắc là được. DateSerial .
 
Upvote 0
Upvote 0
Nhờ các bạn hỗ trợ : Mình đang cần một file khi user nhập liệu thì cho phép, sau khi nhập thì không thể xóa. Mình không biết tìm google với từ khóa nào. Mong các bạn hỗ trợ. Cám ơn các bạn rất nhiều.
 
Upvote 0
nghiank09 đã viết:
Nhờ các bạn hỗ trợ : Mình đang cần một file khi user nhập liệu thì cho phép, sau khi nhập thì không thể xóa. Mình không biết tìm google với từ khóa nào. Mong các bạn hỗ trợ. Cám ơn các bạn rất nhiều.
Nhấp chuột vào đây để mở rộng...
Làm chơi cho vui, chỉ áp dụng được với dân tay mơ. Nếu bạn biết cách xóa dữ liệu đã nhập hoặc nhập dữ liệu mà không bị khóa thì khỏi áp dụng (vì người khác cũng sẽ làm được :D)
 

File đính kèm

Upvote 0
huuthang_bd đã viết:
...khỏi áp dụng (vì người khác cũng sẽ làm được :D)
Nhấp chuột vào đây để mở rộng...
Đương nhiên những gì khoá ở đây thì người dùng chỉ việc đưa lên đây nhờ bẻ khoá.

Nhưng điểm tôi sợ nhất không phải ở chỗ bẻ khoá. Tôi sợ nhất những thằng táo tỉnh, chúng mở khoá, sửa đổi, rồi khoá lại hoàn toàn như chẳng có gì xảy ra.
"Cái đó sếp khoá rồi mà. Em đâu có làm gì được!"
 
Upvote 0
Nhờ các bác check hộ code em sai chỗ nào, kết quả chạy không được như mong muốn.

File của em như sau:
1. Sheet2 : Sheet copy các dữ liệu đường kính và độ cứng tổng hợp về
2. Sheet 1 (các bác không cần soi)
3. Các sheet phía sau : Sheet thứ 3 đến sheet thứ 15 (dữ liệu đường kính), Sheet thứ 16 đến sheet thứ 28 (dữ liệu độ cứng)

Code em chỉ trình độ ABC thôi để đạt mục đích công việc thôi:p
 

File đính kèm

Upvote 0
Bạn thử với cái ni:
PHP: 
Sub Copy_data_Diameter()

Dim sRng As Range
Dim i As Integer, lastRow As Integer
lastRow = 16

For i = 1 To 13
    With Sheets(i + 2)
        MsgBox .Range("A23:Q" & .Range("A" & Rows.Count).End(xlUp).Row).Address '**
        .Range("A23:Q" & .Range("A" & Rows.Count).End(xlUp).Row).Copy
        Sheet2.Range("B" & lastRow).PasteSpecial Paste:=xlPasteValues
        .Range("E5").Copy
        Sheet2.Range("A" & lastRow).PasteSpecial Paste:=xlPasteValues
        lastRow = Sheet2.Range("B65000").End(xlUp).Row + 1    
    End With
Next i   
End Sub
 
Upvote 0
SA_DQ đã viết:
Bạn thử với cái ni:
PHP: 
Sub Copy_data_Diameter()

Dim sRng As Range
Dim i As Integer, lastRow As Integer
lastRow = 16

For i = 1 To 13
    With Sheets(i + 2)
        MsgBox .Range("A23:Q" & .Range("A" & Rows.Count).End(xlUp).Row).Address '**
        .Range("A23:Q" & .Range("A" & Rows.Count).End(xlUp).Row).Copy
        Sheet2.Range("B" & lastRow).PasteSpecial Paste:=xlPasteValues
        .Range("E5").Copy
        Sheet2.Range("A" & lastRow).PasteSpecial Paste:=xlPasteValues
        lastRow = Sheet2.Range("B65000").End(xlUp).Row + 1   
    End With
Next i  
End Sub
Nhấp chuột vào đây để mở rộng...

Chào bác @SA_DQ !!!

Em thử chạy code của bác và đạt được kết quả như mong muốn.
Bác giúp em giải thích code em điểm nào sai với ah.

Tại sao marco Copy_data_hardness em chỉ copy từ Copy_data_diameter chỉnh sửa theo thì không bị sai ah.
Xin bác chỉ giáo giúp em để những lần tới em sửa sai.

Thanks bác nhiều nhiều.
Bài đã được tự động gộp:

Ashiya199 đã viết:
Chào bác @SA_DQ !!!

Em thử chạy code của bác và đạt được kết quả như mong muốn.
Bác giúp em giải thích code em điểm nào sai với ah.

Tại sao marco Copy_data_hardness em chỉ copy từ Copy_data_diameter chỉnh sửa theo thì không bị sai ah.
Xin bác chỉ giáo giúp em để những lần tới em sửa sai.

Thanks bác nhiều nhiều.
Nhấp chuột vào đây để mở rộng...

Chào bác @SA_DQ !!!

Em soi ra rồi. Có phải em sai: thiếu dấu chấm ở chỗ tô đỏ dưới phải không ạh?
.Range("A23:Q" & .Range("A" & Rows.Count).End(xlUp).Row).Copy

Em cám bác nhiều
 
Lần chỉnh sửa cuối:
Upvote 0
Bạn xem 2 dòng lệnh này:
PHP: 
MsgBox .Range("A23:Q" & .Range("A" & Rows.Count).End(xlUp).Row).Address
       .Range("A23:Q" & Range("A" & Rows.Count).End(xlUp).Row).Copy
Khi xài With . . .. End With
 
Upvote 0
Các bác cho em hỏi em muốn từ excel mở một file word lên - tìm và xóa dòng chữ trong file word vừa mở thì làm thế nào ạ.
 
Upvote 0
Mình sử dụng code bên dưới để copy vùng dữ liệu từ sheet1 sang sheet2., nhưng code không hoạt động. Nhờ anh chị chỉ giúp lỗi.
Cảm ơn.
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Sheets("TKB").Range("C46:G53"), Target) Is Nothing Then
Sheets("1A").Range("C5:G12").Value = Sheets("TKB").Range("C46:G53").Value
End If
End Sub
 
Upvote 0
Application.EnableEvents = False
Application.EnableEvents = True
Chào các bác, cho em hỏi khi mình muốn dừng các sự kiện của worksheet thì dùng 2 câu lệnh trên,
Vậy trong userform thì mình dùng lệnh nào tương ứng ạ, ví dụ trong TextBox1_Change ạ.
 
Upvote 0
Duong.bach đã viết:
Application.EnableEvents = False
Application.EnableEvents = True
Chào các bác, cho em hỏi khi mình muốn dừng các sự kiện của worksheet thì dùng 2 câu lệnh trên,
Vậy trong userform thì mình dùng lệnh nào tương ứng ạ, ví dụ trong TextBox1_Change ạ.
Nhấp chuột vào đây để mở rộng...
Bạn sử dụng BeforeUpdate thay cho Change.
 
Upvote 0
leonguyenz đã viết:
Bạn sử dụng BeforeUpdate thay cho Change.
Nhấp chuột vào đây để mở rộng...
Đâu phải trường hợp nào cũng thay thế được đâu bạn.
Duong.bach đã viết:
Application.EnableEvents = False
Application.EnableEvents = True
Chào các bác, cho em hỏi khi mình muốn dừng các sự kiện của worksheet thì dùng 2 câu lệnh trên,
Vậy trong userform thì mình dùng lệnh nào tương ứng ạ, ví dụ trong TextBox1_Change ạ.
Nhấp chuột vào đây để mở rộng...
Bạn sử dụng 1 biến để bật tắt sự kiện.
Mã: 
Private Sub TextBox1_Change()
Static bDisableEvents As Boolean
If Not bDisableEvents Then
    bDisableEvents = True
    '...
    '...
    '...
    bDisableEvents = False
End If
End Sub
 
Upvote 0
Mọi người cho mình hỏi, trong công thức VBA, cũng là tên sheet như mình thấy có lúc người ta đặt trong dấu nháy đơn, có lúc không dùng, vì sao vậy ạ?

ActiveCell.FormulaR1C1 = "='ban 1'!RC+ban2!RC"

Tại 2 vị trí in đậm. Đây là công thức chạy đúng. Ban 1 và Ban2 là tên 2 sheet tồn tại.
 
Lần chỉnh sửa cuối:
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

N
  • Question Question
Tạo file lưu trữ dự liệu tự động (6 người xem)
Trả lời
6
Đọc
60
Hoàng Tuấn 868
H
N
Tạo file lưu trữ dữ liệu tự động trên excel. (4 người xem)
Trả lời
4
Đọc
50
nguyenle01
N
ongke0711
  • Question Question
Tra cứu thông tin mã số thuế (cập nhật lại code cũ) (1 người xem)
    • Thích
    • Cảm ơn
    • Yêu thích
Trả lời
9
Đọc
496
ongke0711
ongke0711
Ả
Cách tạo list Data validation không qua trung gian (3 người xem)
Trả lời
45
Đọc
7K
HOADINH84
H
ongke0711
  • Question Question
Tải hóa đơn điện tử (https://hoadondientu.gdt.gov.vn/) Excel Vba (2 người xem)
    • Thích
    • Yêu thích
    • Cảm ơn
2 3 4
Trả lời
395
Đọc
47K
phamvanquoc.hanamninh
P
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
3
Đọc
128
HieuCD
H
hieuxd
  • Question Question
Khi nhập dữ liệu tự động chèn thêm dòng khi số dòng trong bảng mẫu sắp hết (2 người xem)
Trả lời
26
Đọc
25K
dungpham01
D
D
in ra bị thiếu chữ (1 người xem)
Trả lời
4
Đọc
86
dankedun
D
Momominh
Hỏi công thức tìm tuần thiếu hàng
Trả lời
1
Đọc
73
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
Trả lời
2
Đọc
67
ptm0412
ptm0412
Emyeuexcel
Cộng 4 tuần theo 1 qui luật qui định
Trả lời
34
Đọc
2K
Emyeuexcel
Emyeuexcel
Gà Con yêu VBA
Mở Pass file excel phiên bản .xlsx , xlsm, xlsb
Trả lời
6
Đọc
288
YêuCN
Y
S
Mở 2 cửa sổ riêng biệt (2 người xem)
Trả lời
31
Đọc
24K
ThanhNgan240723
T
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 (2 người xem)
    • Thích
    • Yêu thích
2
Trả lời
146
Đọc
43K
phong_codon
P
N
  • Question Question
Hỗ trợ tiếng việt trong macro
Trả lời
14
Đọc
607
Quang_Hải
Quang_Hải
N
Cài phần mềm đọc số ra chữ (1 người xem)
Trả lời
2
Đọc
143
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
122
HUONGHCKT
H
N
hàm đếm theo dòng
Trả lời
1
Đọc
102
dungpham01
D
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