Chuyển code từ sheet sang worksheet (1 người xem)

[pinklove]

Mình có cái code lượm được của anh Ndu, hiện đang dùng cho từng sheet. Mình có nhiều sheet cùng sử dụng chung code này nên mình muốn đưa nó vào thisworkbook để sử dụng cho tất cả các sheet có tên bắt đầu là "Thang" nhưng làm mãi vẫn lỗi. Nhờ giúp đỡ

Private Sub Worksheet_SelectionChange(ByVal Target As Range) Dim arr, Item, dic As Object, tmp As String
On Error Resume Next
Sheet9.Unprotect "1"
If Not Intersect([B8:B3000], Target) Is Nothing Then
If Target.Count = 1 Then
arr = Sheet7.Range("B4:B1000").Value
Set dic = CreateObject("Scripting.Dictionary")
For Each Item In arr
tmp = CStr(Item)
If Len(tmp) Then
If Not dic.Exists(tmp) Then dic.Add tmp, ""
End If
Next
With Target.Validation
.Delete
If dic.Count Then .Add 3, , , Join(dic.Keys, ",")
End With
End If
End If
Sheet9.Protect "1"
End Sub

 

[khuongvietphong]

Mình có cái code lượm được của anh Ndu, hiện đang dùng cho từng sheet. Mình có nhiều sheet cùng sử dụng chung code này nên mình muốn đưa nó vào thisworkbook để sử dụng cho tất cả các sheet có tên bắt đầu là "Thang" nhưng làm mãi vẫn lỗi. Nhờ giúp đỡ

Bạn sửa từ Private ( từ đầu tiên) thành Public xem sao . Mình không có File nên không Test thử được

 

[ndu96081631]

Mình có cái code lượm được của anh Ndu, hiện đang dùng cho từng sheet. Mình có nhiều sheet cùng sử dụng chung code này nên mình muốn đưa nó vào thisworkbook để sử dụng cho tất cả các sheet có tên bắt đầu là "Thang" nhưng làm mãi vẫn lỗi. Nhờ giúp đỡ

Bạn phải đưa file lên đây chứ ai mà biết trong file thật của bạn Sheet7 và Sheet9 là những sheet nào

 

[pinklove]

Bạn phải đưa file lên đây chứ ai mà biết trong file thật của bạn Sheet7 và Sheet9 là những sheet nào

Em lúc tối mò mãi. Sáng nay em onl bằng di động nên chưa đưa file lên được. Nhưng e nghĩ chỉ cần quy định code áp dụng cho tất cả các sheet có tên bắt đầu là "Thang" là được mà. Trog code thì sheet7 là sheet cố định để lấy nguồn data. Còn sheet9 là sheet hiện thời đang làm việc. E muốn code ko chỉ áp dụng cho sheet9 mà áp dụng cho tất cả các sheet có name bắt đầu bằng "thang"

 

[ndu96081631]

Em lúc tối mò mãi. Sáng nay em onl bằng di động nên chưa đưa file lên được. Nhưng e nghĩ chỉ cần quy định code áp dụng cho tất cả các sheet có tên bắt đầu là "Thang" là được mà. Trog code thì sheet7 là sheet cố định để lấy nguồn data. Còn sheet9 là sheet hiện thời đang làm việc. E muốn code ko chỉ áp dụng cho sheet9 mà áp dụng cho tất cả các sheet có name bắt đầu bằng "thang"

Vấn đề là không biết Sheet9 là sheet nào để Unprotect và Sheet7 là sheet nào để lấy dữ liệu
Nói chung: Không có file thì không áp dụng được gì với code bài 1 cả
Còn nếu viết đại khái thì nó thế này:

Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
  If Left(UCase(Sh.Name), 5) = "THANG" Then
  ''' Code của bạn ở đây
  End If
End Sub

Code trên cho vào Thisworkbook

 

[pinklove]

Vấn đề là không biết Sheet9 là sheet nào để Unprotect và Sheet7 là sheet nào để lấy dữ liệu
Nói chung: Không có file thì không áp dụng được gì với code bài 1 cả
Còn nếu viết đại khái thì nó thế này:

Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
  If Left(UCase(Sh.Name), 5) = "THANG" Then
  ''' Code của bạn ở đây
  End If
End Sub

Code trên cho vào Thisworkbook

Em giờ mới gửi file lên được. Nhờ anh Ndu và các anh chị xem giúp. Em làm theo cách trên của a Ndu vẫn không được. Trong các sheet giờ có 2 đoạn code ở mỗi sheet Tháng đều giống nhau. Em muốn chuyển ra để dùng chung cho tất cả các tháng chỉ 1 lần code. Và với 2 đoạn code nếu có thể nhờ gộp lại thành một code hộ em cho nhẹ bớt ạ.
File của em đây

 

[pinklove]

File của e đã gửi ở trên không hiểu sao khi đem sang máy khác mở lên nó cứ báo lỗi thế này:

Excel found-unreadable content in 'QUAN LY VAN HANH MAY NO.xlsm'. Do you want to recover the contents of this workbook? If you trust the source of this workbook, click yes.

Nó cứ bắt e recover lại save sang file mới. Xin hướng dẫn em cách khắc phục luôn ạ.

 

[ndu96081631]

Em giờ mới gửi file lên được. Nhờ anh Ndu và các anh chị xem giúp. Em làm theo cách trên của a Ndu vẫn không được. Trong các sheet giờ có 2 đoạn code ở mỗi sheet Tháng đều giống nhau. Em muốn chuyển ra để dùng chung cho tất cả các tháng chỉ 1 lần code. Và với 2 đoạn code nếu có thể nhờ gộp lại thành một code hộ em cho nhẹ bớt ạ.
File của em đây

Đưa file lên từ đầu là xong rồi thấy không?
Giờ làm như sau:
- Xóa toàn bộ code sự kiện SelectionChange ở các sheet Thang...
- Cho code dưới đây vào Thisworkbook

Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
  Dim arr, Item, dic As Object, tmp As String
  On Error Resume Next
  [COLOR=#ff0000]If Left(UCase(Sh.Name), 5) = "THANG" Then[/COLOR]
    [COLOR=#0000cd]Sh[/COLOR].Unprotect "1"
    If Not Intersect([COLOR=#0000cd]Sh[/COLOR].Range("B8:B3000"), Target) Is Nothing Then
      If Target.Count = 1 Then
        arr = Sheet7.Range("B4:B1000").Value
        Set dic = CreateObject("Scripting.Dictionary")
        For Each Item In arr
          tmp = CStr(Item)
          If Len(tmp) Then If Not dic.Exists(tmp) Then dic.Add tmp, ""
        Next
        With Target.Validation
          .Delete
          If dic.Count Then .Add 3, , , Join(dic.Keys, ",")
        End With
      End If
    End If
    [COLOR=#0000cd]Sh[/COLOR].Protect "1"
  End If
End Sub

Để ý sẽ thấy code gần như giống với bài 1, chỉ có thêm vào 1 dòng (chỗ màu đỏ) và sửa lại đôi chút (chỗ màu xanh)

 

[ndu96081631]

File của e đã gửi ở trên không hiểu sao khi đem sang máy khác mở lên nó cứ báo lỗi thế này:

Excel found-unreadable content in 'QUAN LY VAN HANH MAY NO.xlsm'. Do you want to recover the contents of this workbook? If you trust the source of this workbook, click yes.

Nó cứ bắt e recover lại save sang file mới. Xin hướng dẫn em cách khắc phục luôn ạ.

File bạn khi download về thấy có tên thế này: QUẢN LÝ VẬN HÀNH MÁY NỔ.xlsm ---> Đọc chẳng ra chữ gì cả
Thử sửa tên file lại xem còn lỗi không?

 

[pinklove]

File bạn khi download về thấy có tên thế này: QUẢN LÝ VẬN HÀNH MÁY NỔ.xlsm ---> Đọc chẳng ra chữ gì cả
Thử sửa tên file lại xem còn lỗi không?

Em đổi lại tên file thành không dấu rồi vẫn bị anh ạ.
Và ở cái code còn lại của sheet từng Tháng em sửa thành thế này dựa vào code của anh vừa sửa nhưng vẫn ko được. A xem giúp em.

Private Sub Worksheet_Change(ByVal Sh As Object, ByVal Target As Range)
If Target.Cells.Count > 1 Then Exit Sub
If Left(UCase(Sh.Name), 5) = "THANG" Then
If Not Intersect(Target, Sh.Range("C8:C3000")) Is Nothing Then
With Target(1, 2)
.Value = Date
End With
End If
If Not Intersect(Target, Sh.Range("E8:E3000")) Is Nothing Then
With Target(1, 2)
.Value = Date
End With
End If
End If
End Sub

 

[pinklove]

À em làm được rồi. E chưa đổi tên sự kiện. Thay thành workbook_sheetchange là ok.

 

[ndu96081631]

Em đổi lại tên file thành không dấu rồi vẫn bị anh ạ.
Và ở cái code còn lại của sheet từng Tháng em sửa thành thế này dựa vào code của anh vừa sửa nhưng vẫn ko được. A xem giúp em.

Tên code sự kiện là Workbook_SheetChange nha bạn (chứ không phải Worksheet_Change)
Code vầy xem:

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
[COLOR=#ff0000]  If Left(UCase(Sh.Name), 5) = "THANG" Then[/COLOR]
    If Target.Cells.Count > 1 Then Exit Sub
    If Not Intersect(Target, [COLOR=#0000cd]Sh[/COLOR].Range("C8:C3000")) Is Nothing Then
      Target(1, 2).Value = Date
    End If
    If Not Intersect(Target, [COLOR=#0000cd]Sh[/COLOR].Range("E8:E3000")) Is Nothing Then
      Target(1, 2).Value = Date
    End If
  End If
End Sub

Cũng xóa hết code sự kiện trong các sheet THANG và cho code trên vào Thisworkbook

 

[pinklove]

Tên code sự kiện là Workbook_SheetChange nha bạn (chứ không phải Worksheet_Change)
Code vầy xem:

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
[COLOR=#ff0000]  If Left(UCase(Sh.Name), 5) = "THANG" Then[/COLOR]
    If Target.Cells.Count > 1 Then Exit Sub
    If Not Intersect(Target, [COLOR=#0000cd]Sh[/COLOR].Range("C8:C3000")) Is Nothing Then
      Target(1, 2).Value = Date
    End If
    If Not Intersect(Target, [COLOR=#0000cd]Sh[/COLOR].Range("E8:E3000")) Is Nothing Then
      Target(1, 2).Value = Date
    End If
  End If
End Sub

Cũng xóa hết code sự kiện trong các sheet THANG và cho code trên vào Thisworkbook

Ngon lành rồi anh. Còn cái lỗi nó báo khi copy file sang máy khác đó anh xem hộ em xem nó bênh gì với.

 

[ndu96081631]

Ngon lành rồi anh. Còn cái lỗi nó báo khi copy file sang máy khác đó anh xem hộ em xem nó bênh gì với.

Lúc đầu download file về cũng bị lỗi, tôi đổi tên file là hết lỗi luôn

 

[pinklove]

Anh Ndu vui lòng xem giúp em cái lỗi của file với. Em đổi tên file rồi vẫn không được. Nó cứ báo lỗi "Excel found-unreadable content in 'tên file.xlsm'. Do you want to recover the contents of this workbook? If you trust the source of this workbook, click yes".
Sau khi e chọn Yes thì có recover lại file, thao tác một lúc khi save nó bắt save as file mới. Đến lúc mở lên nó lại báo thế, sau đó hiện nên cái msg: Removed Feature: Data validation from /xl/worksheets/sheet7.xml part . Em xem ở mục sheet7 (báo cáo theo trạm) thì phần list chọn theo validation ở ô E6 bị mất. Nếu e để nguyên không chọn Validation ở E6 nữa thì nó sẽ ko có lỗi nữa. Em đã chuyển sang chọn Validation ở F6 thì lại bị như thế. Nhờ anh xem giúp em nó là lỗi gì???
File test đây ạ.

 

[pinklove]

Lúc đầu download file về cũng bị lỗi, tôi đổi tên file là hết lỗi luôn

Em ngồi nghịch cả đêm và rút ra được kết luận là nếu bỏ mấy cái code của Validation đi thì sẽ hết lỗi đó. Em nhờ anh kiểm tra hộ xem trong mấy cái code đó có gì không ổn. Em cần tạo list Validation động và bỏ khoảng trống nên e dùng code đó chứ ko dùng list bằng name range được.