Code tự động Viết Hoa đầu mỗi từ

Liên hệ QC
A

Andy Vang

Thành viên mới
Tham gia
15/7/09
Bài viết
34
Được thích
1
Chào các bạn,

Mình được biết là trong Exel có thể Import VBA gì đó giống bên Dot Net nên có thể lập trình để xử lý việc tự động viết hoa đầu mỗi từ. Nhưng mình không rành về cái này lắm nên nhờ các bạn hỗ trợ giúp mình cái này với.

Mình cần ứng dụng này cho file đính kèm bên dưới.
Nhờ các bạn xem qua và giúp mình nhé.
Những cột cần viết Hoa là Full Name, Address và Company.
 

File đính kèm

  • Membership 2014.rar
    99.2 KB · Đọc: 39
truonghuuvang đã viết:
Chào các bạn,

Mình được biết là trong Exel có thể Import VBA gì đó giống bên Dot Net nên có thể lập trình để xử lý việc tự động viết hoa đầu mỗi từ. Nhưng mình không rành về cái này lắm nên nhờ các bạn hỗ trợ giúp mình cái này với.

Mình cần ứng dụng này cho file đính kèm bên dưới.
Nhờ các bạn xem qua và giúp mình nhé.
Những cột cần viết Hoa là Full Name, Address và Company.
Nhấp chuột vào đây để mở rộng...

bạn tải file đính kèm, cho chạy Macro xem có đúng ko nhé !
(mình nhận thấy 1 nhược điểm nhỏ là khi Worksheet_Change tại 3 cột đó được kích hoạt -> ko thể Undo được)

Mã: 
Private Sub Worksheet_Change(ByVal Target As Range)
'http://tinhocvp.blogspot.com/2014/01/tu-ong-chuan-hoa-chuoi-khi-enter-trong.html
Dim str As String
    If Not Intersect(Target, Range("E7:E1000,I7:I1000,J7:J1000")) Is Nothing Then
    If Target.Count = 1 Then
    If Target <> "" Then
        Application.EnableEvents = False
            str = Chuanhoachuoi(Target.Value)
            Target = str
        Application.EnableEvents = True
    End If
    End If
    End If
End Sub

Link: https://www.mediafire.com/?1dm33d5oo4vhzrc
 
Lần chỉnh sửa cuối:
truonghuuvang đã viết:
Chào các bạn,

Mình được biết là trong Exel có thể Import VBA gì đó giống bên Dot Net nên có thể lập trình để xử lý việc tự động viết hoa đầu mỗi từ. Nhưng mình không rành về cái này lắm nên nhờ các bạn hỗ trợ giúp mình cái này với.

Mình cần ứng dụng này cho file đính kèm bên dưới.
Nhờ các bạn xem qua và giúp mình nhé.
Những cột cần viết Hoa là Full Name, Address và Company.
Nhấp chuột vào đây để mở rộng...
Như tôi đã hướng dẫn ở topic kia:
1. Tạo 1 Function để chuẩn hóa chuỗi:
[GPECODE=vb]Function MyProper(S As String) As String
With WorksheetFunction
MyProper = .Proper(.Trim(S))
End With
End Function[/GPECODE]
2. Sử dụng sự kiện Worksheet_Change cho sheet List Member để chuẩn hóa chuỗi nhập vào:
[GPECODE=vb]Private Sub Worksheet_Change(ByVal Target As Range)
Dim Cll As Range
If Intersect(Target, [E7:E1000, I7:J1000]) Is Nothing Then Exit Sub
Application.EnableEvents = False
For Each Cll In Intersect(Target, [E7:E1000, I7:J1000])
If Not IsEmpty(Cll) Then Cll = MyProper(Cll.Value)
Next
Application.EnableEvents = True
End Sub[/GPECODE]
Bạn tham khảo trong file đính kèm, có thể nhập trực tiếp hoặc copy danh sách từ nơi khác dán vào các cột này.
 

File đính kèm

  • Membership 2014.rar
    112 KB · Đọc: 67
Tôi viết code giống như của bạn và đã chạy được. Tuy nhiên, sau khi đóng file và mở lại thì nó lại mất.
Giờ làm sao cho nó chạy vĩnh viễn luôn vậy?

Hjx, mù tịt cái vụ code này lắm ^^
 
truonghuuvang đã viết:
Tôi viết code giống như của bạn và đã chạy được. Tuy nhiên, sau khi đóng file và mở lại thì nó lại mất.
Giờ làm sao cho nó chạy vĩnh viễn luôn vậy?
Hjx, mù tịt cái vụ code này lắm ^^
Nhấp chuột vào đây để mở rộng...
bạn để ý nếu sử dụng từ Excel 2007 trở về sau khi lưu file (Save) có chứa Macro thì có thể Excel sẽ xuất hiện thông báo (lần đầu tiên):

elert.jpg

bạn đọc kỹ nội dung đó, Excel nhắc nhở bạn là File đó đang có Macro.

- Nếu click Yes <=> bạn sẽ lưu file với đuôi .xlsx --> các Macro sẽ bị xóa sạch.

- Nếu click No <=> "hộp thoại" Save As sẽ xuất hiện => bạn điều chỉnh Save As Type:
1. Excel Macro-Enable Workbook ---> cho ra đuôi .xlsm
2. Excel 97_2003 Workbook ---> đuôi .xls (khi lưu với .xls thì có thể sử dụng cho mọi phiên bản của Excel)
 
Lần chỉnh sửa cuối:
nghiaphuc đã viết:
Như tôi đã hướng dẫn ở topic kia:
1. Tạo 1 Function để chuẩn hóa chuỗi:
Mã: 
Function MyProper(S As String) As String
    With WorksheetFunction
        MyProper =[B][COLOR=#ff0000].Proper(.Trim(S))[/COLOR][/B]
    End With
End Function
Nhấp chuột vào đây để mở rộng...

Chỉ từ Excel 2010 trở đi thì chỗ màu đỏ mới hoạt động chính xác à nha!
 
ndu96081631 đã viết:
Chỉ từ Excel 2010 trở đi thì chỗ màu đỏ mới hoạt động chính xác à nha!
Nhấp chuột vào đây để mở rộng...
Ủa, vậy à? Do em đang xài Excel 2010, thử một cái được ngay, cứ ngỡ là ngon ăn rồi chứ.
Vậy thì thay Function trên bởi Function này chắc được nhỉ:
[GPECODE=vb]Function MyProper(S As String) As String
Dim i As Long
S = LCase(WorksheetFunction.Trim(S))
If S = "" Then
MyProper = "": Exit Function
End If
Mid(S, 1, 1) = UCase(Mid(S, 1, 1))
For i = 2 To Len(S) - 1
If Mid(S, i, 1) = " " Then Mid(S, i + 1, 1) = UCase(Mid(S, i + 1, 1))
Next
MyProper = S
End Function[/GPECODE]
 
phucbugis đã viết:
bạn để ý nếu sử dụng từ Excel 2007 trở về sau khi lưu file (Save) có chứa Macro thì có thể Excel sẽ xuất hiện thông báo (lần đầu tiên):

View attachment 120531

bạn đọc kỹ nội dung đó, Excel nhắc nhở bạn là File đó đang có Macro.

- Nếu click Yes <=> bạn sẽ lưu file với đuôi .xlsx --> các Macro sẽ bị xóa sạch.

- Nếu click No <=> "hộp thoại" Save As sẽ xuất hiện => bạn điều chỉnh Save As Type:
1. Excel Macro-Enable Workbook ---> cho ra đuôi .xlsm
2. Excel 97_2003 Workbook ---> đuôi .xls (khi lưu với .xls thì có thể sử dụng cho mọi phiên bản của Excel)
Nhấp chuột vào đây để mở rộng...
Thế lần sau muốn sử dụng lại cái marco này thì làm thế nào?
 
truonghuuvang đã viết:
Thế lần sau muốn sử dụng lại cái marco này thì làm thế nào?
Nhấp chuột vào đây để mở rộng...

hic,
"sử dụng lại cái marco" ---> ko biết bạn đang hỏi về File có chứa Macro hay là về Hàm chuẩn hóa chuỗi (hàm tự tạo) +-+-+-+

mình search trên diễn đàn được bài này --> bạn tham khảo thêm nhé !

Pansy_flower
user-offline.png
...nợ người, nợ đời...
pip.gif


-Tài liệu buổi học VBA đầu tiên

-Tài liệu buổi học VBA thứ hai

-Tài liệu buổi học VBA thứ ba

-Tài liệu buổi học VBA thứ tư
 
Ý mình là làm sao để dùng lại cái file đó mà vẫn chạy được mấy cái code mình đã viết ấy ^^. Mình dốt cái này lắm
 
truonghuuvang đã viết:
Ý mình là làm sao để dùng lại cái file đó mà vẫn chạy được mấy cái code mình đã viết ấy ^^. Mình dốt cái này lắm
Nhấp chuột vào đây để mở rộng...
sau khi làm như hướng dẫn bài #5 thì file lúc này có đuôi là .xlsm hoặc .xls.

Khi mở 1 file có chứa Macro thường xuất hiện 2 thông báo như sau:
TB1
L1.jpg

Click chọn Option sẽ hiện thêm 1 thông báo khác:

L2.jpg

Chọn Enable this content – OK --> bạn có thể sử dụng Macro của file đó !!!

'---
Tìm hiểu thêm: về phần Help có sẵn của Excel
Mở 1 file Excel bất kỳ - click F1 – hộp thoại Excel Help sẽ hiện ra – nhập từ khóa enable macro -> ra các kết quả liên quan vấn đề sử dụng Macro.
 
nghiaphuc đã viết:
Ủa, vậy à? Do em đang xài Excel 2010, thử một cái được ngay, cứ ngỡ là ngon ăn rồi chứ.
Vậy thì thay Function trên bởi Function này chắc được nhỉ:
[GPECODE=vb]Function MyProper(S As String) As String
Dim i As Long
S = LCase(WorksheetFunction.Trim(S))
If S = "" Then
MyProper = "": Exit Function
End If
Mid(S, 1, 1) = UCase(Mid(S, 1, 1))
For i = 2 To Len(S) - 1
If Mid(S, i, 1) = " " Then Mid(S, i + 1, 1) = UCase(Mid(S, i + 1, 1))
Next
MyProper = S
End Function[/GPECODE]
Nhấp chuột vào đây để mở rộng...
Thật ra với Proper nói riêng hay ChangeCase nói chung, viết vừa đủ xài bấy nhiêu đó cũng xong. Tuy nhiên để viết cho tổng quát (hoạt động gần giống như Upper, Lower, Proper) cũng không phải chuyện dễ
Nhân tiên tặng các bạn mấy code này:
Mã: 
Private Function ChangeCaseFromString(ByVal Text As String, ByVal CaseType As Long) As String
  'CaseType = 1 ---> Change to lower-case
  'CaseType = 2 ---> Change to UPPER-case
  'CaseType = 3 ---> Change to Proper-case
  Dim i As Long, tmp As String
  On Error Resume Next
  If Trim(Text) <> "" And Not (IsNumeric(Text)) Then
    Select Case CaseType
      Case 1: ChangeCaseFromString = LCase(Text)
      Case 2: ChangeCaseFromString = UCase(Text)
      Case 3
        tmp = Trim(Text)
        If Len(tmp) = 1 Then
          ChangeCaseFromString = UCase(tmp)
        Else
          tmp = UCase(Left(tmp, 1)) & LCase(Mid(tmp, 2, Len(tmp)))
          For i = 2 To Len(tmp)
            If UCase(Mid(tmp, i, 1)) <> LCase(Mid(tmp, i, 1)) Then
              If UCase(Mid(tmp, i - 1, 1)) = LCase(Mid(tmp, i - 1, 1)) Then
                tmp = Left(tmp, i - 1) & Replace(tmp, Mid(tmp, i, 1), UCase(Mid(tmp, i, 1)), i, 1)
              End If
            End If
          Next
          ChangeCaseFromString = tmp
        End If
    End Select
  Else
    ChangeCaseFromString = Text
  End If
End Function
Mã: 
Function ChangeCase(ByVal Source_Array, ByVal CaseType As Long)
  'CaseType = 1 ---> Change to lower-case
  'CaseType = 2 ---> Change to UPPER-case
  'CaseType = 3 ---> Change to Proper-case
  Dim aTmp, strTmp As String, i As Long, j As Long
  On Error Resume Next
  aTmp = Source_Array
  If Not IsArray(aTmp) Then aTmp = Array(aTmp)
  strTmp = Join(aTmp, " ")
  If Len(strTmp) Then
    For i = LBound(aTmp) To UBound(aTmp)
      aTmp(i) = ChangeCaseFromString(aTmp(i), CaseType)
    Next
  Else
    For i = LBound(aTmp, 1) To UBound(aTmp, 1)
      For j = LBound(aTmp, 2) To UBound(aTmp, 2)
        aTmp(i, j) = ChangeCaseFromString(aTmp(i, j), CaseType)
      Next
    Next
  End If
  ChangeCase = aTmp
End Function
Mã: 
Sub ChangeCaseFromRange(ByVal Source_Range As Range, ByVal CaseType As Long)
  'CaseType = 1 ---> Change to lower-case
  'CaseType = 2 ---> Change to UPPER-case
  'CaseType = 3 ---> Change to Proper-case
  Dim Source_Array, Area As Range, i As Long, j As Long
  On Error Resume Next
  With Source_Range
    If .Count = 1 Then
      .Formula = ChangeCase(.Formula, CaseType)
    Else
      For Each Area In .Areas
        Source_Array = Area.Formula
        Source_Array = ChangeCase(Source_Array, CaseType)
        Area.Formula = Source_Array
      Next
    End If
  End With
End Sub
- Theo thứ tự ưu tiên từ trên xuống, muốn dùng code thứ 3 thì đương nhiên phải có trước code 1 và 2 (để hổ trợ)
- Function thứ 1 là code gốc: ChangeCase từ 1 chuổi, trả về kết quả cũng là chuổi
- Function thứ 2 hoạt động được với chuổi hoặc mảng, riêng với mảng thì hổ trợ mảng 1 chiều hoặc 2 chiều (gần giống với ham ChangeCase của Excel). Nó dùng Function thứ 1 để hổ trợ
- Sub cuối cùng dùng để hổ trợ ChangeCase mọi thứ trên bảng tính (đối số là Range). Điều đặc biệt là không làm mất công thức hiện có
---------------
Thí nghiệm:
Mã: 
Sub Test()
  ChangeCaseFromRange Selection, 3 '' thay số 3 thành 1 hoặc 2 tùy nhu cầu
End Sub
hoặc:
Mã: 
Private Sub Worksheet_Change(ByVal Target As Range)
  Dim Rng As Range
  On Error Resume Next
  If Not Intersect(Target, [E2:E5000]) Is Nothing Then
    Set Rng = Intersect(Target, [E2:E5000])
    Application.EnableEvents = False
    ChangeCaseFromRange Rng, 2
  End If
  Application.EnableEvents = True
End Sub
-----------------------
Code này viết cũng khá lâu nhưng chưa có điều kiện để test cho chắc
 

File đính kèm

  • ChangeCase_2.xls
    55 KB · Đọc: 36
Lần chỉnh sửa cuối:
ndu96081631 đã viết:
Thật ra với Proper nói riêng hay ChangeCase nói chung, viết vừa đủ xài bấy nhiêu đó cũng xong. Tuy nhiên để viết cho tổng quát (hoạt động gần giống như Upper, Lower, Proper) cũng không phải chuyện dễ
Nhân tiên tặng các bạn mấy code này:
Mã: 
Private Function ChangeCaseFromString(ByVal Text As String, ByVal CaseType As Long) As String
  'CaseType = 1 ---> Change to lower-case
  'CaseType = 2 ---> Change to UPPER-case
  'CaseType = 3 ---> Change to Proper-case
  Dim i As Long, tmp As String
  On Error Resume Next
  If Trim(Text) <> "" And Not (IsNumeric(Text)) Then
    Select Case CaseType
      Case 1: ChangeCaseFromString = LCase(Text)
      Case 2: ChangeCaseFromString = UCase(Text)
      Case 3
        tmp = Trim(Text)
        If Len(tmp) = 1 Then
          ChangeCaseFromString = UCase(tmp)
        Else
          tmp = UCase(Left(tmp, 1)) & LCase(Mid(tmp, 2, Len(tmp)))
          For i = 2 To Len(tmp)
            If UCase(Mid(tmp, i, 1)) <> LCase(Mid(tmp, i, 1)) Then
              If UCase(Mid(tmp, i - 1, 1)) = LCase(Mid(tmp, i - 1, 1)) Then
                tmp = Left(tmp, i - 1) & Replace(tmp, Mid(tmp, i, 1), UCase(Mid(tmp, i, 1)), i, 1)
              End If
            End If
          Next
          ChangeCaseFromString = tmp
        End If
    End Select
  Else
    ChangeCaseFromString = Text
  End If
End Function
Mã: 
Function ChangeCase(ByVal Source_Array, ByVal CaseType As Long)
  'CaseType = 1 ---> Change to lower-case
  'CaseType = 2 ---> Change to UPPER-case
  'CaseType = 3 ---> Change to Proper-case
  Dim aTmp, strTmp As String, i As Long, j As Long
  On Error Resume Next
  aTmp = Source_Array
  If Not IsArray(aTmp) Then aTmp = Array(aTmp)
  strTmp = Join(aTmp, " ")
  If Len(strTmp) Then
    For i = LBound(aTmp) To UBound(aTmp)
      aTmp(i) = ChangeCaseFromString(aTmp(i), CaseType)
    Next
  Else
    For i = LBound(aTmp, 1) To UBound(aTmp, 1)
      For j = LBound(aTmp, 2) To UBound(aTmp, 2)
        aTmp(i, j) = ChangeCaseFromString(aTmp(i, j), CaseType)
      Next
    Next
  End If
  ChangeCase = aTmp
End Function
Mã: 
Sub ChangeCaseFromRange(ByVal Source_Range As Range, ByVal CaseType As Long)
  'CaseType = 1 ---> Change to lower-case
  'CaseType = 2 ---> Change to UPPER-case
  'CaseType = 3 ---> Change to Proper-case
  Dim Source_Array, Area As Range, i As Long, j As Long
  On Error Resume Next
  With Source_Range
    If .Count = 1 Then
      .Formula = ChangeCase(.Formula, CaseType)
    Else
      For Each Area In .Areas
        Source_Array = Area.Formula
        Source_Array = ChangeCase(Source_Array, CaseType)
        Area.Formula = Source_Array
      Next
    End If
  End With
End Sub
- Theo thứ tự ưu tiên từ trên xuống, muốn dùng code thứ 3 thì đương nhiên phải có trước code 1 và 2 (để hổ trợ)
- Function thứ 1 là code gốc: ChangeCase từ 1 chuổi, trả về kết quả cũng là chuổi
- Function thứ 2 hoạt động được với chuổi hoặc mảng, riêng với mảng thì hổ trợ mảng 1 chiều hoặc 2 chiều (gần giống với ham ChangeCase của Excel). Nó dùng Function thứ 1 để hổ trợ
- Sub cuối cùng dùng để hổ trợ ChangeCase mọi thứ trên bảng tính (đối số là Range). Điều đặc biệt là không làm mất công thức hiện có
---------------
Thí nghiệm:
Mã: 
Sub Test()
  ChangeCaseFromRange Selection, 3 '' thay số 3 thành 1 hoặc 2 tùy nhu cầu
End Sub
-----------------------
Code này viết cũng khá lâu nhưng chưa có điều kiện để test cho chắc
Nhấp chuột vào đây để mở rộng...
Code thầy viết tổng quát quá, sao thầy không làm thành 1 addins cho dễ sử dụng ạ?
 
chuot0106 đã viết:
Code thầy viết tổng quát quá, sao thầy không làm thành 1 addins cho dễ sử dụng ạ?
Nhấp chuột vào đây để mở rộng...

Thích thì bạn cứ Save thành AddIn mà xài, đâu có vấn đề gì chứ
Save xong, bạn sẽ có 2 hàm ChangeCaseFromString (chỉ dùng với đối số là String) và hàm ChangeCase dùng được cho cả String lẫn Array
Riêng với Sub ChangeCaseFromRange, muốn xài nó sẽ hơi rắc rối 1 chút. Ít nhất cũng phải tạo menu để gọi
Nói chung: Mọi thứ đã có, tùy ý ai thích "xáo nấu" thế nào cũng được
 
phucbugis đã viết:
bạn tải file đính kèm, cho chạy Macro xem có đúng ko nhé !
(mình nhận thấy 1 nhược điểm nhỏ là khi Worksheet_Change tại 3 cột đó được kích hoạt -> ko thể Undo được)

Mã: 
Private Sub Worksheet_Change(ByVal Target As Range)
'http://tinhocvp.blogspot.com/2014/01/tu-ong-chuan-hoa-chuoi-khi-enter-trong.html
Dim str As String
    If Not Intersect(Target, Range("E7:E1000,I7:I1000,J7:J1000")) Is Nothing Then
    If Target.Count = 1 Then
    If Target <> "" Then
        Application.EnableEvents = False
            str = Chuanhoachuoi(Target.Value)
            Target = str
        Application.EnableEvents = True
    End If
    End If
    End If
End Sub

Link: https://www.mediafire.com/?1dm33d5oo4vhzrc
Nhấp chuột vào đây để mở rộng...
Sao mình tải về chỉnh lại thành 1 cột C nhưng báo lỗi (ambiguous name detected: worsheet_change) giúp em!!!
 
snow25 đã viết:
Bạn gửi cái code sửa lên xem nào.
Nhấp chuột vào đây để mở rộng...
Private Sub Worksheet_Change(ByVal Target As Range)
Dim str As String
If Not Intersect(Target, Range("C7:C1000")) Is Nothing Then
If Target.Count = 1 Then
If Target <> "" Then
Application.EnableEvents = False
str = Chuanhoachuoi(Target.Value)
Target = str
Application.EnableEvents = True
End If
End If
End If
End Sub
 
Bạn phải đăng nhập hoặc đăng ký để trả lời bài viết tại đây.
Web KT

Bài viết mới nhất

LuuAnh980
  • Question
Code lấy dữ liệu từ 3 file con.
Trả lời
13
Đọc
174
LuuAnh980
LuuAnh980
B
  • Question
Chuyển đổi dữ liệu sạng dạng mảng
Trả lời
5
Đọc
85
ongke0711
ongke0711
S
Nhờ giúp đỡ code in toàn bộ danh sách có điều kiện
Trả lời
6
Đọc
141
Hoàng Tuấn 868
H
S
  • Question
Không lấy đủ dữ liệu bằng kết nối ADO
Trả lời
0
Đọc
63
shnhatha221108
S
T
Không hiện dữ liệu ở ô công thức
Trả lời
3
Đọc
80
thien-16
T
Xem thêm…

Facebook

Giaiphapexcel.com

Group

DIỄN ĐÀN GIẢI PHÁP EXCEL Group 1
DIỄN ĐÀN GIẢI PHÁP EXCEL Group 2

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

Back
Top Bottom