- Tham gia
- 29/4/08
- Bài viết
- 95
- Được thích
- -2
Mình có một danh sách bài hát ( file đính kèm) giờ muốn chia theo như hình đã tô màu bên cạnh thì làm theo cách nào để nhanh chóng nhất, ai biết thì chỉ giùm
Option Explicit
Sub SaoChép()
Dim Rng As Range, sRng As Range, cRng As Range
Dim MyAdd As String: Dim Rws As Long, VTr As Byte
Const NotNhac As String = "NHAC HOT THANG "
Columns("B:E").Delete
Set Rng = Range([A1], [A65500].End(xlUp))
Set sRng = Rng.Find(NotNhac, , xlFormulas, xlPart)
If Not sRng Is Nothing Then
MyAdd = sRng.Address
Do
[D65500].End(xlUp).Offset(2, -2).Value = sRng.Value
Set cRng = sRng.Offset(3)
Rws = cRng.CurrentRegion.Rows.Count
[COLOR="blue"]' Set cRng = cRng.Resize(Rws \ 2)'[/COLOR]
With [B65500].End(xlUp)
cRng.Resize(Rws \ 2).Copy Destination:=.Offset(2)
cRng.Offset(Rws \ 2).Resize(Rws \ 2 + 1).Copy Destination:=.Offset(2, 2)
End With
Set sRng = Rng.FindNext(sRng)
Loop While Not sRng Is Nothing And sRng.Address <> MyAdd
End If
Application.DisplayAlerts = False
For Each Rng In Range([B3], [B65500].End(xlUp).Offset(2))
If InStr(Rng.Value, NotNhac) Then
Rng.HorizontalAlignment = xlCenter
Rng.Resize(, 4).Merge
Else
VTr = InStr(Rng.Value, " ")
If VTr Then
Rng.Offset(, 1).Value = Mid(Rng.Value, VTr + 1, 99)
Rng.Value = Left(Rng.Value, VTr - 1)
End If
With Rng.Offset(, 2)
VTr = InStr(.Value, " ")
If VTr Then
.Offset(, 1).Value = Mid(.Value, VTr + 1, 99)
.Value = Left(.Value, VTr - 1)
End If
End With
End If
Next Rng
Application.DisplayAlerts = True
End Sub
Lần này thì quá cả iêu cầu đó nha!
Mất cả buổi mới xong cái định dạng!
Mỗi 1 trang tính trong file của bạn có những đặc thù khác nhau & ngưởi viết macro dựa vô nó để xử lý khối dữ liệu;quả thật là tuyệt vời. Nhưng không hiểu sao khi mình chạy với một đọan list khác thì không được và thấy
báo lỗi số 9. Bạn giúp mình với nhé
Đoạn Code ở trên là sử dụng Víual basic phải không bạn?Option Explicit
Sub SaoChép()
Dim Rng As Range, sRng As Range, cRng As Range
Dim MyAdd As String: Dim Rws As Long, VTr As Byte
Const NotNhac As String = "NHAC HOT THANG "
Columns("B:E").Delete
Set Rng = Range([A1], [A65500].End(xlUp))
Set sRng = Rng.Find(NotNhac, , xlFormulas, xlPart)
If Not sRng Is Nothing Then
MyAdd = sRng.Address
Do
[D65500].End(xlUp).Offset(2, -2).Value = sRng.Value
Set cRng = sRng.Offset(3)
Rws = cRng.CurrentRegion.Rows.Count
' Set cRng = cRng.Resize(Rws \ 2)'
With [B65500].End(xlUp)
cRng.Resize(Rws \ 2).Copy Destination:=.Offset(2)
cRng.Offset(Rws \ 2).Resize(Rws \ 2 + 1).Copy Destination:=.Offset(2, 2)
End With
Set sRng = Rng.FindNext(sRng)
Loop While Not sRng Is Nothing And sRng.Address <> MyAdd
End If
Application.DisplayAlerts = False
For Each Rng In Range([B3], [B65500].End(xlUp).Offset(2))
If InStr(Rng.Value, NotNhac) Then
Rng.HorizontalAlignment = xlCenter
Rng.Resize(, 4).Merge
Else
VTr = InStr(Rng.Value, " ")
If VTr Then
Rng.Offset(, 1).Value = Mid(Rng.Value, VTr + 1, 99)
Rng.Value = Left(Rng.Value, VTr - 1)
End If
With Rng.Offset(, 2)
VTr = InStr(.Value, " ")
If VTr Then
.Offset(, 1).Value = Mid(.Value, VTr + 1, 99)
.Value = Left(.Value, VTr - 1)
End If
End With
End If
Next Rng
Application.DisplayAlerts = True
End Sub
File list nhạc của mình thì tất cả duới tên ca sỹ đều có làn gạch đôi hết.Mình cũng đã thử chạy trên chính file gốc nhưng vẫn báo lỗi như vậy. Phiền bạn thêm lần nữa giúp mình với nhé. Cám ơn bạn nhiều lắm
Đây là file gốc bạn giúp mình với nhéBạn đưa file gốc lên đi, canh sao cho nhiều dữ liệu nhất đó!
To SonDauBac: đó là VBA bạn à, (VB for Application)
Option Explicit
Dim Rng As Range, sRng As Range, cRg As Range
Dim MyAdd As String: Dim Rws As Long, VTr As Long
[B]Sub SaoChepDanhMuc()[/B]
Const NotNhac As String = "==": Dim Sh As Worksheet
Const KT As String = " ": [B] On Error Resume Next[/B]
Dim Cls As Range, Rg0 As Range, Color_ As Byte
Set Sh = Sheets("KQua"): Columns("B:E").Delete
Sheets("S2").Select: Sh.Columns("A:E").Delete
Set Rng = Range([A1], [A65500].End(xlUp))
Set sRng = Rng.Find(NotNhac, , xlFormulas, xlPart)
If Not sRng Is Nothing Then
MyAdd = sRng.Address
Do
With Sh.[c65500].End(xlUp).Offset(IIf(VTr < 1, 2, 3), -2)
.Value = sRng.Offset(-1).Value
.Offset(1).Value = KT & NotNhac
End With
Set cRg = sRng.Offset(2): VTr = VTr + 1
Rws = cRg.CurrentRegion.Rows.Count
With Sh.[A65500].End(xlUp)
cRg.Resize(Rws \ 2).Copy Destination:=.Offset(2)
cRg.Offset(Rws \ 2).Resize(Rws \ 2 + 1).Copy Destination:=.Offset(2, 2)
End With
Set sRng = Rng.FindNext(sRng)
Loop While Not sRng Is Nothing And sRng.Address <> MyAdd
End If
Application.DisplayAlerts = False: Sh.Select
Set Rng = Range([A1], [A65500].End(xlUp))
Set sRng = Rng.Find(NotNhac)
If Not sRng Is Nothing Then
MyAdd = sRng.Address
Randomize: Color_ = 34 + Int(6 * Rnd())
Do
With sRng.Offset(-1)
.HorizontalAlignment = xlCenter:
.Resize(, 4).Merge
For VTr = 7 To 10
With .Resize(, 4).Borders(VTr)
.LineStyle = xlContinuous: .Weight = xlMedium
End With
Next VTr
End With
sRng.Font.ColorIndex = 2
Set cRg = sRng.Offset(2).Resize(sRng.Offset(2, 2).CurrentRegion.Rows.Count, 4)
cRg.Resize(, 4).Interior.ColorIndex = Color_
Color_ = Color_ + 1: Rws = cRg.Rows.Count
Set Rg0 = Union(cRg.Cells(1, 1).Resize(Rws), cRg.Cells(1, 3).Resize(Rws))
Rg0.NumberFormat = "00000": If Color_ > 41 Then Color_ = 34
For Each Cls In Rg0
VTr = InStr(1, Cls.Value, KT)
If VTr Then
Cls.Offset(, 1).Value = Mid(Cls.Value, VTr + 1, 99)
Cls.Value = Left(Cls.Value, VTr - 1)
End If
Next Cls
Set sRng = Rng.FindNext(sRng)
Loop While Not sRng Is Nothing And sRng.Address <> MyAdd
End If
Application.DisplayAlerts = True
[B]End Sub[/B]
Cám ơn bạn mình đã làm đuợc rồiĐể tiện sử dụng, bạn cần đổi tên trang tính chứa DL (dữ liệu) của bạn thành 'S2' & lấy 1 trang tính không DL đổi thành 'KQua'; Chỉ sau đó mới chạy macro trên;Mã:Option Explicit Dim Rng As Range, sRng As Range, cRg As Range Dim MyAdd As String: Dim Rws As Long, VTr As Long [B]Sub SaoChepDanhMuc()[/B] Const NotNhac As String = "==": Dim Sh As Worksheet Const KT As String = " ": [B] On Error Resume Next[/B] Dim Cls As Range, Rg0 As Range, Color_ As Byte Set Sh = Sheets("KQua"): Columns("B:E").Delete Sheets("S2").Select: Sh.Columns("A:E").Delete Set Rng = Range([A1], [A65500].End(xlUp)) Set sRng = Rng.Find(NotNhac, , xlFormulas, xlPart) If Not sRng Is Nothing Then MyAdd = sRng.Address Do With Sh.[c65500].End(xlUp).Offset(IIf(VTr < 1, 2, 3), -2) .Value = sRng.Offset(-1).Value .Offset(1).Value = KT & NotNhac End With Set cRg = sRng.Offset(2): VTr = VTr + 1 Rws = cRg.CurrentRegion.Rows.Count With Sh.[A65500].End(xlUp) cRg.Resize(Rws \ 2).Copy Destination:=.Offset(2) cRg.Offset(Rws \ 2).Resize(Rws \ 2 + 1).Copy Destination:=.Offset(2, 2) End With Set sRng = Rng.FindNext(sRng) Loop While Not sRng Is Nothing And sRng.Address <> MyAdd End If Application.DisplayAlerts = False: Sh.Select Set Rng = Range([A1], [A65500].End(xlUp)) Set sRng = Rng.Find(NotNhac) If Not sRng Is Nothing Then MyAdd = sRng.Address Randomize: Color_ = 34 + Int(6 * Rnd()) Do With sRng.Offset(-1) .HorizontalAlignment = xlCenter: .Resize(, 4).Merge For VTr = 7 To 10 With .Resize(, 4).Borders(VTr) .LineStyle = xlContinuous: .Weight = xlMedium End With Next VTr End With sRng.Font.ColorIndex = 2 Set cRg = sRng.Offset(2).Resize(sRng.Offset(2, 2).CurrentRegion.Rows.Count, 4) cRg.Resize(, 4).Interior.ColorIndex = Color_ Color_ = Color_ + 1: Rws = cRg.Rows.Count Set Rg0 = Union(cRg.Cells(1, 1).Resize(Rws), cRg.Cells(1, 3).Resize(Rws)) Rg0.NumberFormat = "00000": If Color_ > 41 Then Color_ = 34 For Each Cls In Rg0 VTr = InStr(1, Cls.Value, KT) If VTr Then Cls.Offset(, 1).Value = Mid(Cls.Value, VTr + 1, 99) Cls.Value = Left(Cls.Value, VTr - 1) End If Next Cls Set sRng = Rng.FindNext(sRng) Loop While Not sRng Is Nothing And sRng.Address <> MyAdd End If Application.DisplayAlerts = True [B]End Sub[/B]
Sở dĩ fải thêm dòng lệnh đó vì một số tiêu đề viết sẵn nhưng chưa có bài hát nào ở fần nội dụng bên dưới nó.
(Những mong không cần đưa file lên: Tốn tài nguyên quá, bạn thông cảm!)