Chuyên đề giải đáp những thắc mắc về code VBA

quochr

Thành viên mới
Tham gia ngày
14 Tháng tám 2013
Bài viết
18
Được thích
2
Điểm
365
Tuổi
33
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:

Bandit

Thành viên mới
Tham gia ngày
12 Tháng chín 2019
Bài viết
42
Được thích
30
Điểm
165
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
 

quanghai1969

Thành viên gạo cội
Tham gia ngày
21 Tháng hai 2009
Bài viết
5,762
Được thích
7,360
Điểm
860
Nơi ở
Thuận An, Bình Dương
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

huuthang_bd

Chuyên gia GPE
Tham gia ngày
10 Tháng chín 2008
Bài viết
7,953
Được thích
9,292
Điểm
860
Nơi ở
TP.HCM
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
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
 

thnghiachau

Thành viên tiêu biểu
Tham gia ngày
14 Tháng chín 2009
Bài viết
705
Được thích
560
Điểm
860
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
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
 

quanghai1969

Thành viên gạo cội
Tham gia ngày
21 Tháng hai 2009
Bài viết
5,762
Được thích
7,360
Điểm
860
Nơi ở
Thuận An, Bình Dươ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
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
 

quanghai1969

Thành viên gạo cội
Tham gia ngày
21 Tháng hai 2009
Bài viết
5,762
Được thích
7,360
Điểm
860
Nơi ở
Thuận An, Bình Dươ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
À 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
 

snow25

Thành viên gắn bó
Tham gia ngày
24 Tháng bảy 2018
Bài viết
2,718
Được thích
2,669
Điểm
360
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
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 .
 

thnghiachau

Thành viên tiêu biểu
Tham gia ngày
14 Tháng chín 2009
Bài viết
705
Được thích
560
Điểm
860

nghiank09

Thành viên mới
Tham gia ngày
1 Tháng ba 2012
Bài viết
32
Được thích
4
Điểm
365
Tuổi
30
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.
 

huuthang_bd

Chuyên gia GPE
Tham gia ngày
10 Tháng chín 2008
Bài viết
7,953
Được thích
9,292
Điểm
860
Nơi ở
TP.HCM
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.
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

VetMini

Chuyên gia GPE
Tham gia ngày
21 Tháng mười hai 2012
Bài viết
10,359
Được thích
12,634
Điểm
1,560
...khỏi áp dụng (vì người khác cũng sẽ làm được :D)
Đươ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!"
 

Ashiya199

Thành viên mới
Tham gia ngày
19 Tháng bảy 2019
Bài viết
21
Được thích
2
Điểm
165
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

SA_DQ

/(hông là gì!
Thành viên danh dự
Tham gia ngày
8 Tháng sáu 2006
Bài viết
11,884
Được thích
17,852
Điểm
1,860
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
 

Ashiya199

Thành viên mới
Tham gia ngày
19 Tháng bảy 2019
Bài viết
21
Được thích
2
Điểm
165
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
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:

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.
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:
Top Bottom