Hỏi về cách chia cột trong excel

[tuan206791]

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

 

[SA_DQ]

Bạn có đòi kẻ khung không đó?

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

 

[tuan206791]

bạn chỉ giùm mình cách kẻ khung luôn và có thể thực hiện với tất cả các mục khác chứ không riên gì mục "nhạc hot" vì trong list nhạc của mình có những danh sách ca sỹ khác nữa mà mình muốn chia theo như vậy luôn. Rất cám ơn bạn vì đã giúp đỡ mình

Mình xem bài bạn gửi cho mình , mình rất thích bạn giỏi thật. Mình muốn gửi file lên diễn đàn hỏi bạn một chút nữa mà không thấy mục tải file lên, Nếu có thể bạn cho mình xin mail và giúp đỡ mình thêm một chút nữa thì tốt. Cám ơn bạn nhiều

Mình có file list nhạc muốn kẻ ô trình bày theo mẫu gửi kèm bên duới 1 cách nhanh nhất nhưng không biết cách, hôm trước đã có người làm giúp mình nhưng chưa đuợc hòan thành, mình nhờ ai biết thì giúp mình với. Mình cám ơn nhiều

 

[SA_DQ]

Mời bạn xem file


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!

 

[tuan206791]

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!

Cám ơn bạn nhiều, mình xem bạn làm 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é

 

[ChanhTQ@]

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é

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;

Như file đầu của bạn có các tiêu đề hoàn toàn na ná nhau & các từ đầu câu luôn giống nhau
Còn trang tính trong file sau thì dự vô các lằn gạch đôi của bạn dước tác giả ca khúc,. . .

Như vậy 1 macro xử lý cho 2 trường hợp cùng chung 1 trang tính là chưa có;

Nếu muốn xử lý cả các ca khúc trong tháng & các tác giả, thì bạn cần đưa trang tính đó lên mới được.

 

[tuan206791]

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

 

[sondaubac]

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

Đoạn Code ở trên là sử dụng Víual basic phải không bạn?

 

[SA_DQ]

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

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)

 

[tuan206791]

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)

Đây là file gốc bạn giúp mình với nhé

 

[SA_DQ]

Macro đó chỉ cần thêm 1 dòng lệnh là OK:

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]

Để 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;

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!)

 

[tuan206791]

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]

Để 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;

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!)

Cám ơn bạn mình đã làm đuợc rồi