Tạo sheet mới theo điều kiện? (1 người xem)

Hoàng Nhật Phương · 5/1/18

Xin chào các bạn
Có 1 vấn đề như sau, rất mong nhận được sự giúp đỡ của các bạn ạ:

Tôi có một tập tin, trong tập tin này có 2 sheet có tên "Data" và "Form"
Trong sheet Data tại vùng C2:C11 tôi nhập dữ liệu lần lượt "a,b,c,...,j"

Mong muốn làm sao đặt con trỏ chuột vào ô nào nếu ô đó có dữ liệu thì sẽ copy từ sheet "Form" có tên ô đó.

Ví dụ khi đặt con trỏ chuột vào (lựa chọn) các ô:
C4 có dữ liệu là c
C7 có dữ liệu là f
C4 có dữ liệu là j

Sau đó chạy code thì tạo ra 3 sheet có tên lần lượt là: c,f,j giống như sheet "Form"

huuthang_bd · 5/1/18

hpkhuong đã viết:

Mã:

Public Sub GPE()
Dim Cll As Range
If TypeOf Selection Is Range Then
    For Each Cll In Selection
        Sheets("Form").Copy After:=Sheets(Sheets.Count)
        Sheets(Sheets.Count).Name = Cll.Value
    Next
End If
End Sub

If để làm gì ta.

huuthang_bd · 5/1/18

Cẩn thận khi sử dụng.
Đang chọn cả sheet mà lỡ tay chạy macro thì xác định

.

Hoàng Nhật Phương · 5/1/18

hpkhuong đã viết:

Mã:

Public Sub GPE()
Dim Cll As Range
If TypeOf Selection Is Range Then
    For Each Cll In Selection
        Sheets("Form").Copy After:=Sheets(Sheets.Count)
        Sheets(Sheets.Count).Name = Cll.Value
    Next
End If
End Sub

Cảm ơn hpkhuong & anh huuthang_bd đã quan tâm.
Nếu trong trường hợp chọn 2 ô có dữ liệu và 1 ô rỗng (không có dữ liệu) thì code lỗi tạo được 3 sheet nhưng không đặt hết tên được cho cả 3 sheet vì có 1 ô rỗng.

Nhờ các bạn thêm giúp trường hợp loại bỏ lỗi này với ạ.

Ba Tê · 5/1/18

Nguyễn Hoàng Oanh Thơ đã viết:
Cảm ơn hpkhuong & anh huuthang_bd đã quan tâm.
Nếu trong trường hợp chọn 2 ô có dữ liệu và 1 ô rỗng (không có dữ liệu) thì code lỗi tạo được 3 sheet nhưng không đặt hết tên được cho cả 3 sheet vì có 1 ô rỗng.

Nhờ các bạn thêm giúp trường hợp loại bỏ lỗi này với ạ.

Chú ý vùng chọn trước khi chạy code nhé, chọn cả sheet Data là "điếc luôn".

PHP:

Public Sub GPE()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim Cll As Range, Ws As Worksheet, Myname As String
For Each Cll In Selection
    If Cll.Value <> Empty Then
        Myname = Cll.Value
        For Each Ws In Worksheets
            If Ws.Name = Myname Then Ws.Delete
        Next Ws
        Sheets("Form").Copy After:=Sheets(Sheets.Count)
        Sheets(Sheets.Count).Name = Myname
    End If
Next Cll
Sheets("Data").Select
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub

NguyenNgocThuHien · 5/1/18

PHP:

Sub InsertSheets()
    Dim dicSheets As Scripting.Dictionary, dicObjSheet As Scripting.Dictionary
    Dim wsSource As Worksheet
    Dim rngSource As Range
    Dim objTemp As Object
    Dim rngTemp As Range
    Dim lngNumSheetBefor As Long, aSheets, lngIndex As Long
    Dim wsBefor As Object
    
    If Selection Is Nothing Then
        MsgBox "Khong tim thay vung danh sach"
    Else
        If TypeOf Selection Is Range Then
            Set rngSource = Selection
            
        Else
            MsgBox "Phai chon mot vung truoc khi chay macro"
            Exit Sub
        End If
    End If
    
    On Error Resume Next
    Set wsSource = ThisWorkbook.Sheets("Form")
    wsSource.Visible = xlSheetVisible
    If Err.Number <> 0 Then
        MsgBox "Khong tim thay sheet  nguon"
        Exit Sub
    End If
    
    On Error GoTo 0
    Set dicSheets = New Scripting.Dictionary 'danh sach ten cac sheet dang co và se duoc them
    Set dicObjSheet = New Scripting.Dictionary 'danh sách cac shet da co hien tai
    dicSheets.CompareMode = TextCompare
    
    For Each objTemp In ThisWorkbook.Sheets
        dicSheets.Add objTemp.Name, objTemp
        dicObjSheet.Add objTemp, ""
    Next
    lngNumSheetBefor = dicSheets.Count
    
    For Each rngTemp In rngSource.Cells
        If VarType(rngTemp.Value) = vbString Then
            If dicSheets.Exists(rngTemp.Value) Then
                MsgBox "Bi trung sheet ten: " & rngTemp.Value
                GoTo FreeMemony
            Else
                dicSheets.Add rngTemp.Value, Nothing
            End If
        End If
    Next
    
    If lngNumSheetBefor = dicSheets.Count Then
        MsgBox "Khong tim thay phan tu moi nao"
        GoTo FreeMemony
    End If
    
    aSheets = dicSheets.Keys
    Set wsBefor = ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
    For lngIndex = lngNumSheetBefor To dicSheets.Count - 1
        wsSource.Copy , wsBefor
        Set wsBefor = FindNewSheet(dicObjSheet, ThisWorkbook)
        dicObjSheet.Add wsBefor, ""
        wsBefor.Name = aSheets(lngIndex)
    Next
    
    
    
    
    
FreeMemony:
    dicSheets.RemoveAll
    dicObjSheet.RemoveAll
    Set dicSheets = Nothing
    Set dicObjSheet = Nothing
    Set rngSource = Nothing
    Set rngTemp = Nothing
    
    Set wsBefor = Nothing
    Set wsSource = Nothing
    Set objTemp = Nothing
    
    
End Sub


Private Function FindNewSheet(dicListShOl As Scripting.Dictionary, wb As Workbook) As Object
    Dim objTemp As Object
    For Each objTemp In wb.Sheets
        If Not dicListShOl.Exists(objTemp) Then
            Set FindNewSheet = objTemp
            Exit Function
        End If
    Next
    Err.Raise vbObjectError + 10, , "Not found new sheet."
End Function

Gió Đông · 5/1/18

diễn đàn giờ nhiều members với avatar nữ tài năng xinh đẹp, thật nếu là thật thì chúc mừng diễn đàn đã chuyển giai đoạn ... phát triển ...

NguyenNgocThuHien · 5/1/18

hpkhuong đã viết:
Sheets(Sheets.Count).Name = Cll.Value

Ba Tê đã viết:
Sheets(Sheets.Count).Name = Myname

chơi mấy cái count nguy hiểm lắm, dùng cái activesheet cho an tâm hơn.
https://stackoverflow.com/questions...eet-to-end-of-workbook-with-hidden-worksheets

HieuCD · 5/1/18

NguyenNgocThuHien đã viết:

PHP:

Sub InsertSheets()
    Dim dicSheets As Scripting.Dictionary, dicObjSheet As Scripting.Dictionary
    Dim wsSource As Worksheet
    Dim rngSource As Range
    Dim objTemp As Object
    Dim rngTemp As Range
    Dim lngNumSheetBefor As Long, aSheets, lngIndex As Long
    Dim wsBefor As Object
   
    If Selection Is Nothing Then
        MsgBox "Khong tim thay vung danh sach"
    Else
        If TypeOf Selection Is Range Then
            Set rngSource = Selection
           
        Else
            MsgBox "Phai chon mot vung truoc khi chay macro"
            Exit Sub
        End If
    End If
   
    On Error Resume Next
    Set wsSource = ThisWorkbook.Sheets("Form")
    wsSource.Visible = xlSheetVisible
    If Err.Number <> 0 Then
        MsgBox "Khong tim thay sheet  nguon"
        Exit Sub
    End If
   
    On Error GoTo 0
    Set dicSheets = New Scripting.Dictionary 'danh sach ten cac sheet dang co và se duoc them
    Set dicObjSheet = New Scripting.Dictionary 'danh sách cac shet da co hien tai
    dicSheets.CompareMode = TextCompare
   
    For Each objTemp In ThisWorkbook.Sheets
        dicSheets.Add objTemp.Name, objTemp
        dicObjSheet.Add objTemp, ""
    Next
    lngNumSheetBefor = dicSheets.Count
   
    For Each rngTemp In rngSource.Cells
        If VarType(rngTemp.Value) = vbString Then
            If dicSheets.Exists(rngTemp.Value) Then
                MsgBox "Bi trung sheet ten: " & rngTemp.Value
                GoTo FreeMemony
            Else
                dicSheets.Add rngTemp.Value, Nothing
            End If
        End If
    Next
   
    If lngNumSheetBefor = dicSheets.Count Then
        MsgBox "Khong tim thay phan tu moi nao"
        GoTo FreeMemony
    End If
   
    aSheets = dicSheets.Keys
    Set wsBefor = ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
    For lngIndex = lngNumSheetBefor To dicSheets.Count - 1
        wsSource.Copy , wsBefor
        Set wsBefor = FindNewSheet(dicObjSheet, ThisWorkbook)
        dicObjSheet.Add wsBefor, ""
        wsBefor.Name = aSheets(lngIndex)
    Next
   
   
   
   
   
FreeMemony:
    dicSheets.RemoveAll
    dicObjSheet.RemoveAll
    Set dicSheets = Nothing
    Set dicObjSheet = Nothing
    Set rngSource = Nothing
    Set rngTemp = Nothing
   
    Set wsBefor = Nothing
    Set wsSource = Nothing
    Set objTemp = Nothing
   
   
End Sub


Private Function FindNewSheet(dicListShOl As Scripting.Dictionary, wb As Workbook) As Object
    Dim objTemp As Object
    For Each objTemp In wb.Sheets
        If Not dicListShOl.Exists(objTemp) Then
            Set FindNewSheet = objTemp
            Exit Function
        End If
    Next
    Err.Raise vbObjectError + 10, , "Not found new sheet."
End Function

Vấn đề nhìn có vẽ đơn giản, nhưng với chuyên gia thì ... quá hay

NguyenNgocThuHien · 5/1/18

HieuCD đã viết:
Vấn đề nhìn có vẽ đơn giản, nhưng với chuyên gia thì ... quá hay

Anh này lại đùa ro òi!

Ba Tê · 5/1/18

NguyenNgocThuHien đã viết:
chơi mấy cái count nguy hiểm lắm, dùng cái activesheet cho an tâm hơn.
https://stackoverflow.com/questions...eet-to-end-of-workbook-with-hidden-worksheets

Chỉ là viết theo thưc tế tình huống tác giả yêu cầu (chọn Range trong cột C)
Biết tới đâu làm tới đó. Có gì thì tác giả "la lên" tính tiếp.
Làm sao dự đoán hết các tình huống "nếu". Đã có "nếu có ô rỗng" rồi đó.

Hoàng Nhật Phương · 6/1/18

[QUOTE="NguyenNgocThuHien đã viết:

PHP:

Sub InsertSheets()
    Dim dicSheets As Scripting.Dictionary, dicObjSheet As Scripting.Dictionary
    Dim wsSource As Worksheet
    Dim rngSource As Range
    Dim objTemp As Object
    Dim rngTemp As Range
    Dim lngNumSheetBefor As Long, aSheets, lngIndex As Long
    Dim wsBefor As Object
   
    If Selection Is Nothing Then
        MsgBox "Khong tim thay vung danh sach"
    Else
        If TypeOf Selection Is Range Then
            Set rngSource = Selection
           
        Else
            MsgBox "Phai chon mot vung truoc khi chay macro"
            Exit Sub
        End If
    End If
   
    On Error Resume Next
    Set wsSource = ThisWorkbook.Sheets("Form")
    wsSource.Visible = xlSheetVisible
    If Err.Number <> 0 Then
        MsgBox "Khong tim thay sheet  nguon"
        Exit Sub
    End If
   
    On Error GoTo 0
    Set dicSheets = New Scripting.Dictionary 'danh sach ten cac sheet dang co và se duoc them
    Set dicObjSheet = New Scripting.Dictionary 'danh sách cac shet da co hien tai
    dicSheets.CompareMode = TextCompare
   
    For Each objTemp In ThisWorkbook.Sheets
        dicSheets.Add objTemp.Name, objTemp
        dicObjSheet.Add objTemp, ""
    Next
    lngNumSheetBefor = dicSheets.Count
   
    For Each rngTemp In rngSource.Cells
        If VarType(rngTemp.Value) = vbString Then
            If dicSheets.Exists(rngTemp.Value) Then
                MsgBox "Bi trung sheet ten: " & rngTemp.Value
                GoTo FreeMemony
            Else
                dicSheets.Add rngTemp.Value, Nothing
            End If
        End If
    Next
   
    If lngNumSheetBefor = dicSheets.Count Then
        MsgBox "Khong tim thay phan tu moi nao"
        GoTo FreeMemony
    End If
   
    aSheets = dicSheets.Keys
    Set wsBefor = ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
    For lngIndex = lngNumSheetBefor To dicSheets.Count - 1
        wsSource.Copy , wsBefor
        Set wsBefor = FindNewSheet(dicObjSheet, ThisWorkbook)
        dicObjSheet.Add wsBefor, ""
        wsBefor.Name = aSheets(lngIndex)
    Next
   
   
   
   
   
FreeMemony:
    dicSheets.RemoveAll
    dicObjSheet.RemoveAll
    Set dicSheets = Nothing
    Set dicObjSheet = Nothing
    Set rngSource = Nothing
    Set rngTemp = Nothing
   
    Set wsBefor = Nothing
    Set wsSource = Nothing
    Set objTemp = Nothing
   
   
End Sub


Private Function FindNewSheet(dicListShOl As Scripting.Dictionary, wb As Workbook) As Object
    Dim objTemp As Object
    For Each objTemp In wb.Sheets
        If Not dicListShOl.Exists(objTemp) Then
            Set FindNewSheet = objTemp
            Exit Function
        End If
    Next
    Err.Raise vbObjectError + 10, , "Not found new sheet."
End Function

, post: 836063, member: 163936"]Chỉ là viết theo thưc tế tình huống tác giả yêu cầu (chọn Range trong cột C)
Biết tới đâu làm tới đó. Có gì thì tác giả "la lên" tính tiếp.
Làm sao dự đoán hết các tình huống "nếu". Đã có "nếu có ô rỗng" rồi đó.[/QUOTE]

Hihihi, thật tuyệt vời.
Cảm ơn các bạn, cảm ơn diễn đàn!

huuthang_bd · 6/1/18

Nguyễn Hoàng Oanh Thơ đã viết:
Hihihi, thật tuyệt vời.
Cảm ơn các bạn, cảm ơn diễn đàn!

Tưởng bạn "la làng" thì tính tiếp chứ xong rồi thì thôi.
Cần lưu ý khi chọn các ô có giá trị là số hoặc có ký tự mà Excel không cho phép đặt tên sheet.

Hoàng Nhật Phương · 6/1/18

huuthang_bd đã viết:
Tưởng bạn "la làng" thì tính tiếp chứ xong rồi thì thôi.
Cần lưu ý khi chọn các ô có giá trị là số hoặc có ký tự mà Excel không cho phép đặt tên sheet.

Dạ vâng Anh.
Đúng rồi ạ , với các ký tự đặc biệt thì có vấn đề ạ.

Hê anh huuthang_bd có thể bổ sung giúp Oanh Thơ phần còn lại này được không ạ.

Cảm ơn anh huuthang_bd nhiều.

NguyenNgocThuHien · 6/1/18

huuthang_bd đã viết:
Tưởng bạn "la làng" thì tính tiếp chứ xong rồi thì thôi.
Cần lưu ý khi chọn các ô có giá trị là số hoặc có ký tự mà Excel không cho phép đặt tên sheet.

Vẽ đường cho hươu nó chạy sao anh?
http://codevba.com/excel/valid_sheet_name.htm#.WlDDlTKLSM8

be_09 · 6/1/18

NguyenNgocThuHien đã viết:
Vẽ đường cho hươu nó chạy sao anh?
http://codevba.com/excel/valid_sheet_name.htm#.WlDDlTKLSM8

Cần gì phải vẽ đường, chỉ cần làm vầy thì nó ra 1 đống ký tự đặt biệt để biết mà tránh, xem hình.

befaint · 6/1/18

Rảnh rỗi tìm link

https://msdn.microsoft.com/en-us/library/aa243899(v=vs.60).aspx

Tạo sheet mới theo điều kiện? (1 người xem)

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

Thành viên gắn bó

File đính kèm

Chuyên gia GPE

Chuyên gia GPE

Thành viên gắn bó

Cạo Rồi Khỏi Gội

Cute Black Cat

File đính kèm

BĂNG TRÔI

Cute Black Cat

Chuyên gia GPE

Cute Black Cat

Cạo Rồi Khỏi Gội

Thành viên gắn bó

Chuyên gia GPE

Thành viên gắn bó

Cute Black Cat

Biên Hòa, Đồng Nai

|||||||||||||

Đếm ngược thời gian