Giúp sữa code theo Nhóm không phân biệt chữ hoa chử thường (1 người xem)

[minhtuan55]

Chào cả Nhà GPE !
Hiện em đang dụng đoạn code sau. Code tách rất ok. Nhưng có phân biệt chử hoa, chử thường nên em muốn sửa lại không phân biệt chữ hoa chử thường

Sub tachtheonhom()
 Dim dic As Object, Retval(), Tm
        Dim eR(), eRmax, Id, i, j
        Set dic = CreateObject("Scripting.Dictionary")
        Tm = Range("B3:C26").Value
        For i = 1 To UBound(Tm, 1)
        If Not dic.Exists(Tm(i, 2)) Then
        j = j + 1
        dic.Add Tm(i, 2), j
        ReDim Preserve eR(1 To j)
        eR(j) = 1
        ReDim Preserve Retval(1 To UBound(Tm, 1), 1 To j)
        Retval(1, j) = Tm(i, 2)
        End If
        Id = dic.Item(Tm(i, 2))
        eR(Id) = eR(Id) + 1
        If eRmax < eR(Id) Then eRmax = eR(Id)
        Retval(eR(Id), Id) = Tm(i, 1)
        Next
        Range("G2:P45").ClearContents
        Range("G2").Resize(eRmax, UBound(Retval, 2)) = Retval
        Set dic = Nothing
End Sub

Dữ liệu tách cúa code hiện tai ( Chưa ok )



Dữ liệu tách cúa code mong muốn

 

[♫ђöล♥ßล†♥†µ♫]

Trong Dic bạn thay Tm(i, 2) bằng UCase(Tm(i, 2))

 

[minhtuan55]

Trong Dic bạn thay Tm(i, 2) bằng UCase(Tm(i, 2))

Thank bác . Bác trà lời VÔ CÙng Hoàn Toàn Chính xác

Sub tachtheonhom()
 Dim dic As Object, Retval(), Tm
        Dim eR(), eRmax, Id, i, j
        Set dic = CreateObject("Scripting.Dictionary")
        Tm = Range("B3:C26").Value
        For i = 1 To UBound(Tm, 1)
        If Not dic.Exists(UCase(Tm(i, 2))) Then
        j = j + 1
        dic.Add UCase(Tm(i, 2)), j
        ReDim Preserve eR(1 To j)
        eR(j) = 1
        ReDim Preserve Retval(1 To UBound(Tm, 1), 1 To j)
        Retval(1, j) = UCase(Tm(i, 2))
        End If
        Id = dic.Item(UCase(Tm(i, 2)))
        eR(Id) = eR(Id) + 1
        If eRmax < eR(Id) Then eRmax = eR(Id)
        Retval(eR(Id), Id) = Tm(i, 1)
        Next
        Range("G2:P45").ClearContents
        Range("G2").Resize(eRmax, UBound(Retval, 2)) = Retval
        Set dic = Nothing
End Sub

 

[♫ђöล♥ßล†♥†µ♫]

Thank bác . Bác trà lời VÔ CÙng Hoàn Toàn Chính xác

Sub tachtheonhom()
    Dim dic As Object, Retval(), Tm
    Dim eR(), eRmax, Id, i, j
Set dic = CreateObject("Scripting.Dictionary")
dic.CompareMode = vbTextCompare         '<--------------------
Tm = Range("B3:C26").Value
For i = 1 To UBound(Tm, 1)
 
    If Not dic.Exists(Tm(i, 2)) Then
        j = j + 1
        dic.Add Tm(i, 2), j
        ReDim Preserve eR(1 To j)
        eR(j) = 1
        ReDim Preserve Retval(1 To UBound(Tm, 1), 1 To j)
        Retval(1, j) = Tm(i, 2)
    End If
    Id = dic.Item(Tm(i, 2))
    eR(Id) = eR(Id) + 1
    If eRmax < eR(Id) Then eRmax = eR(Id)
    Retval(eR(Id), Id) = Tm(i, 1)
Next
Range("G2:P45").ClearContents
Range("G2").Resize(eRmax, UBound(Retval, 2)) = Retval
Set dic = Nothing
End Sub

 

[minhtuan55]

Làm như thế này cho đúng bài vở

Sub tachtheonhom()
    Dim dic As Object, Retval(), Tm
    Dim eR(), eRmax, Id, i, j
Set dic = CreateObject("Scripting.Dictionary")
Tm = Range("B3:C26").Value
For i = 1 To UBound(Tm, 1)
    dic.CompareMode = vbTextCompare         '<--------------------
    If Not dic.Exists(Tm(i, 2)) Then
        j = j + 1
        dic.Add Tm(i, 2), j
        ReDim Preserve eR(1 To j)
        eR(j) = 1
        ReDim Preserve Retval(1 To UBound(Tm, 1), 1 To j)
        Retval(1, j) = Tm(i, 2)
    End If
    Id = dic.Item(Tm(i, 2))
    eR(Id) = eR(Id) + 1
    If eRmax < eR(Id) Then eRmax = eR(Id)
    Retval(eR(Id), Id) = Tm(i, 1)
Next
Range("G2:P45").ClearContents
Range("G2").Resize(eRmax, UBound(Retval, 2)) = Retval
Set dic = Nothing
End Sub

dạ bác Vậy sẵn bác chỉ em cái đoạn code chuyển 1 vùng chử thường sang 1 vùng chử Hoa luôn. Em cảm ơn bác trước. Em tự viết như thế này mà nó không hiểu

Sub ThuongsangHoa()
Range("b1:b3").Value = LCase(Range("a1:a3").Value)
End Sub

 

[befaint]

dic.CompareMode = vbTextCompare cho ra ngoài vòng lặp...?
Mấy chỗ ReDim Preserve không cần dùng tới được không?
Có nên kiểm tra Tm(i, 2) trước khi kiểm tra trong dic, kiểm tra Retval có kết quả hay không?
....

 

[♫ђöล♥ßล†♥†µ♫]

dạ bác Vậy sẵn bác chỉ em cái đoạn code chuyển 1 vùng chử thường sang 1 vùng chử Hoa luôn. Em cảm ơn bác trước. Em tự viết như thế này mà nó không hiểu

Sub ThuongsangHoa()
Range("b1:b3").Value = LCase(Range("a1:a3").Value)
End Sub

Úi Lcase nó như vầy mà

​

 

[♫ђöล♥ßล†♥†µ♫]

dic.CompareMode = vbTextCompare cho ra ngoài vòng lặp...?
Mấy chỗ ReDim Preserve không cần dùng tới được không?
Có nên kiểm tra Tm(i, 2) trước khi kiểm tra trong dic, kiểm tra Retval có kết quả hay không?
....

Em bài viết rồi mà chẳng hiểu sao nó vẫn vậy mà còn chui vào trong cái khung kia nữa anh à

 

[befaint]

Úi Lcase nó như vầy mà

View attachment 194455​

Nếu cùng dòng/ cột thì mình có thể split(lcase(join(vung,dau_phan_cach)),dau_phan_cach). Đoán thế không biết được không?

 

[phulien1902]

dạ bác Vậy sẵn bác chỉ em cái đoạn code chuyển 1 vùng chử thường sang 1 vùng chử Hoa luôn. Em cảm ơn bác trước. Em tự viết như thế này mà nó không hiểu

Sub ThuongsangHoa()
Range("b1:b3").Value = LCase(Range("a1:a3").Value)
End Sub

Bạn thử:

Sub ThuongsangHoa()
    Dim c As Range
    For Each c In Range("A1:A3")
        c.Offset(, 1).Value = UCase(c.Value)
    Next
End Sub

 

[minhtuan55]

Úi Lcase nó như vầy mà

View attachment 194455​

Bác ơi em có dùng đoạn code này hơi cùi chuối để chuyển 1 vùng chử thường sang chử Hoa và Ngược lại. BÁc xem giúp em có lổi gì không

Sub thuongsangHOA()
Dim sArr(), dArr(), I As Long, K As Long, R As Long
sArr = Range("A1:A14").Value ' DU LIEU DAU VAO
R = UBound(sArr)
ReDim dArr(1 To R, 1 To 1) ' 3 COT
For I = 1 To R
        K = K + 1
        dArr(K, 1) = UCase(sArr(I, 1))
Next I
' OUTPUT
On Error Resume Next
Range("B1:B21").ClearContents
Range("b1:b14") = dArr ' 3 COT
End Sub

 

[♫ђöล♥ßล†♥†µ♫]

Bác ơi em có dùng đoạn code này hơi cùi chuối để chuyển 1 vùng chử thường sang chử Hoa và Ngược lại. BÁc xem giúp em có lổi gì không

Sub thuongsangHOA()
Dim sArr(), dArr(), I As Long, K As Long, R As Long
sArr = Range("A1:A14").Value ' DU LIEU DAU VAO
R = UBound(sArr)
ReDim dArr(1 To R, 1 To 1) ' 3 COT
For I = 1 To R
        K = K + 1
        dArr(K, 1) = UCase(sArr(I, 1))
Next I
' OUTPUT
On Error Resume Next
Range("B1:B21").ClearContents
Range("b1:b14") = dArr ' 3 COT
End Sub

Cái này là ngon rồi chứ cùi chuối gì nữa anh. Em mà làm thì em chuyển sang Function chứ em không dùng Sub

 

[minhtuan55]

Bạn thử:

Sub ThuongsangHoa()
    Dim c As Range
    For Each c In Range("A1:A3")
        c.Offset(, 1).Value = UCase(c.Value)
    Next
End Sub

cảm ơn bác. COde bác ngắn gọn dể hiểu chính xác

 

[HieuCD]

Cái này là ngon rồi chứ cùi chuối gì nữa anh. Em mà làm thì em chuyển sang Function chứ em không dùng Sub

Dùng Function như thế nào, chỉ mình với

 

[♫ђöล♥ßล†♥†µ♫]

Dùng Function như thế nào, chỉ mình với

Úi úi lại chọc quê em út rồi đó

 

[VetMini]

Dùng function thì như vầy nè:
[b1:b3] = [Index(Upper(A1:A3),)]