Giúp mình tạo 2 macro này với

tuan206791 · 26/5/11

Mình có 2 macro cần tạo, nhờ mọi người giúp đỡ. Mình biết ít về excel mong mọi người thông cảm

SA_DQ · 26/5/11

/-)ây là macro đánh số thứ tự các bài hát của bạn

(Còn iêu cầu thứ hai chưa rõ lắm!)

PHP:

Option Explicit
Sub SoThuTu()
 Const Crit As String = "==="
 Dim Rng As Range, sRng As Range, Cls As Range, tRng As Range
 Dim STT As Long, MyAdd As String

 Set Rng = Range([b1], [B65500].End(xlUp))
 Set sRng = Rng.Find(Crit, , xlFormulas, xlPart)
 If Not sRng Is Nothing Then
    MyAdd = sRng.Address
    Do
        Set tRng = Range(sRng.End(xlDown), sRng.End(xlDown).End(xlDown))
        For Each Cls In tRng
            STT = STT + 1
            Cls.Offset(, -1).Value = STT
        Next Cls
        Set sRng = Rng.FindNext(sRng)
    Loop While Not sRng Is Nothing And sRng.Address <> MyAdd
 End If
End Sub

tuan206791 · 26/5/11

Mình thử chạy mà chẳng được bạn xem giúp giùm mình với, mình có ghi chú thích trong cả 2 macro rồi mà

tuan206791 · 26/5/11

mình muốn tạo macro khi chạy sẽ sẽ thể hiện ở sheet kết quả. Giúp mình nhé

ChanhTQ@ · 26/5/11

Bạn xem trong file đính kèm nha

Bạn thử xoá cột đã đánh số TT
Sau đó bấm tổ hợp {CTRL}+{SHIFT}+S

tuan206791 · 26/5/11

ChanhTQ@ đã viết:
Bạn thử xoá cột đã đánh số TT
Sau đó bấm tổ hợp {CTRL}+{SHIFT}+S

Mình thử rồi đã chạy rất ok. bạn giúp mình với macro còn lại đi. Cám ơn bạn trước nhé

tuan206791 · 26/5/11

Macro 2 thì bạn ChanhTQ@ đã giúp mình tạo ok rồi, giờ chỉ cần làm thêm macro 1 là good

viehoai · 26/5/11

tuan206791 đã viết:
Mình thử rồi đã chạy rất ok. bạn giúp mình với macro còn lại đi. Cám ơn bạn trước nhé

Bạn xem file thử nhé

tuan206791 · 26/5/11

viehoai đã viết:
Bạn xem file thử nhé

Trong file lỗi chỗ này bạn Viethoai " <Filename>3</Filename>"

viehoai · 26/5/11

tuan206791 đã viết:
Trong file lỗi chỗ này bạn Viethoai " <Filename>3</Filename>"

Bạn load lại file đi mình hồi nảy bị nhầm

tuan206791 · 26/5/11

viehoai đã viết:
Bạn load lại file đi mình hồi nảy bị nhầm

Bạn giúp mình sửa 1 chút nữa dòng đầu tiên "<SOFTWAREMOBILE_MANAGER> => </SOFTWARESMOBILE_MANAGER>" (Cái này bạn lưu ý có thêm chữ S mình mới phát hiện ra) và "<ID>" kế ngay sau số thứ tự thành "</ID>"
Cái này thì chắc đơn giản đối với bạn nhưng thực tình mình không biết

SA_DQ · 26/5/11

Thêm 1 tham khảo

PHP:

Option Explicit

Sub KQua()
 Const SWMM As String = "SOFTWARESMOBILE_MANAGER>"
 Const ID As String = "ID>"
 Const FName As String = "Filename>":           Const Path As String = "Path>"
 
 Const TLoai As String = "    <Theloai />":          Const LMay As String = "    <Loaimay />"
 Const Khac As String = "    <Khac />"
 Dim Sh As Worksheet, Rng As Range, Cls As Range
 Dim VTr As Byte, Dem As Long
 
 Set Sh = ThisWorkbook.Worksheets("Data"):      Sheets("KQua").Select
 Set Rng = Sh.Range(Sh.[A2], Sh.[A65500].End(xlUp))
 For Each Cls In Rng
    VTr = InStr(Cls.Value, "KIET\") + 4
    Dem = Dem + 1
    With [A65500].End(xlUp).Offset(1)
        .Value = "  </" & SWMM
        .Offset(1).Value = "  <" & SWMM
        .Offset(2).Value = "  <" & ID & Right("0000" & CStr(Dem), 5) & "</" & ID
        .Offset(3).Value = "<" & FName & Mid(Cls.Value, VTr + 1, 99) & "</" & FName
        .Offset(4).Value = "    <" & Path & Left(Cls.Value, VTr - 1) & "</" & Path
        .Offset(5).Value = TLoai
        .Offset(6).Value = LMay
        .Offset(7).Value = Khac
    End With
 Next Cls
End Sub

tuan206791 · 26/5/11

HYen17 đã viết:

PHP:

Option Explicit

Sub KQua()
 Const SWMM As String = "SOFTWARESMOBILE_MANAGER>"
 Const ID As String = "ID>"
 Const FName As String = "Filename>":           Const Path As String = "Path>"
 
 Const TLoai As String = "    <Theloai />":          Const LMay As String = "    <Loaimay />"
 Const Khac As String = "    <Khac />"
 Dim Sh As Worksheet, Rng As Range, Cls As Range
 Dim VTr As Byte, Dem As Long
 
 Set Sh = ThisWorkbook.Worksheets("Data"):      Sheets("KQua").Select
 Set Rng = Sh.Range(Sh.[A2], Sh.[A65500].End(xlUp))
 For Each Cls In Rng
    VTr = InStr(Cls.Value, "KIET\") + 4
    Dem = Dem + 1
    With [A65500].End(xlUp).Offset(1)
        .Value = "  </" & SWMM
        .Offset(1).Value = "  <" & SWMM
        .Offset(2).Value = "  <" & ID & Right("0000" & CStr(Dem), 5) & "</" & ID
        .Offset(3).Value = "<" & FName & Mid(Cls.Value, VTr + 1, 99) & "</" & FName
        .Offset(4).Value = "    <" & Path & Left(Cls.Value, VTr - 1) & "</" & Path
        .Offset(5).Value = TLoai
        .Offset(6).Value = LMay
        .Offset(7).Value = Khac
    End With
 Next Cls
End Sub

cái này bị lỗi từ chỗ này bạn ơi"<Filename>HAC VIET NAM\ANH THUY\Cam on tinh yeu - Anh Thuy.mp3</Filename>", bạn sửa lại giúp mình xem sao nhé. Thank bạn!

Ba Tê · 26/5/11

tuan206791 đã viết:
cái này bị lỗi từ chỗ này bạn ơi"<Filename>HAC VIET NAM\ANH THUY\Cam on tinh yeu - Anh Thuy.mp3</Filename>", bạn sửa lại giúp mình xem sao nhé. Thank bạn!

Bạn sửa dòng này

HTML:

VTr = InStr(Cls.Value, "KIET\") + 4

thành thế này thử xem:

HTML:

VTr = Application.WorksheetFunction.Find("\", Cls.Value, 18)

sealand · 26/5/11

Đây là Macro tạo Văn bản và tô mầu, trước mắt tôi đặt màu cố định (Bạn có thể dùng biến rồi gán màu theo đúng sheet data)

Mã:

Sub TaoDS()
Dim Kq(), i, j, tam, Rng As Range
Set Rng = Sheet1.Range(Sheet1.[A2], Sheet1.[A2].End(4))
For i = 1 To Rng.Count
ReDim Preserve Kq(1 To i * 8)
Kq(i * 8 - 7) = Space(2) & "</SOFTWARESMOBILE_MANAGER>"
Kq(i * 8 - 6) = Space(2) & "<SOFTWARESMOBILE_MANAGER>"
Kq(i * 8 - 5) = Space(3) & "<ID>" & Right("0000" & i, 5) & "</ID>"
Kq(i * 8 - 4) = Space(3) & "<Filename>" & Right(Rng(i).Value, InStr(1, StrReverse(Rng(i).Value), "\") - 1) & "</Filename>"
Kq(i * 8 - 3) = Space(3) & "<Path>" & Left(Rng(i).Value, Len(Rng(i)) - Len(Kq(i * 8 - 4)) + 23) & "</Path>"
Kq(i * 8 - 2) = Space(3) & "<Theloai />"
Kq(i * 8 - 1) = Space(3) & "<Loaimay />"
Kq(i * 8) = Space(3) & "<Khac />"
Next
Sheet2.Columns("A").Clear
Sheet2.[A1].Resize(UBound(Kq)) = WorksheetFunction.Transpose(Kq)
Set Rng = Sheet2.[A1].Resize(UBound(Kq))
For i = 1 To UBound(Kq) / 8
With Rng(i * 8 - 7).Resize(2).Interior
        .ColorIndex = 36
        .Pattern = xlSolid
End With
With Rng(i * 8 - 2).Resize(3).Interior
        .ColorIndex = 36
        .Pattern = xlSolid
End With
Rng(i * 8 - 5).Resize(3).Font.ColorIndex = 44
Rng(i * 8 - 5).Characters(8, 5).Font.ColorIndex = 10
Rng(i * 8 - 4).Characters(14, Len(Rng(i * 8 - 4)) - 24).Font.ColorIndex = 5
Rng(i * 8 - 3).Characters(10, Len(Rng(i * 8 - 3)) - 16).Font.ColorIndex = 7
Next
End Sub

sealand · 27/5/11

Ba Tê đã viết:
Bạn sửa dòng này

HTML:

VTr = InStr(Cls.Value, "KIET\") + 4

thành thế này thử xem:

HTML:

VTr = Application.WorksheetFunction.Find("\", Cls.Value, 18)

Hì, trong VBA ta dùng Instr() chứ dùng hàm bảng tính nó phức tạp và chậm đi.

tuan206791 · 27/5/11

sealand đã viết:

Đây là Macro tạo Văn bản và tô mầu, trước mắt tôi đặt màu cố định (Bạn có thể dùng biến rồi gán màu theo đúng sheet data)

Mã:

Sub TaoDS()
Dim Kq(), i, j, tam, Rng As Range
Set Rng = Sheet1.Range(Sheet1.[A2], Sheet1.[A2].End(4))
For i = 1 To Rng.Count
ReDim Preserve Kq(1 To i * 8)
Kq(i * 8 - 7) = Space(2) & "</SOFTWARESMOBILE_MANAGER>"
Kq(i * 8 - 6) = Space(2) & "<SOFTWARESMOBILE_MANAGER>"
Kq(i * 8 - 5) = Space(3) & "<ID>" & Right("0000" & i, 5) & "</ID>"
Kq(i * 8 - 4) = Space(3) & "<Filename>" & Right(Rng(i).Value, InStr(1, StrReverse(Rng(i).Value), "\") - 1) & "</Filename>"
Kq(i * 8 - 3) = Space(3) & "<Path>" & Left(Rng(i).Value, Len(Rng(i)) - Len(Kq(i * 8 - 4)) + 23) & "</Path>"
Kq(i * 8 - 2) = Space(3) & "<Theloai />"
Kq(i * 8 - 1) = Space(3) & "<Loaimay />"
Kq(i * 8) = Space(3) & "<Khac />"
Next
Sheet2.Columns("A").Clear
Sheet2.[A1].Resize(UBound(Kq)) = WorksheetFunction.Transpose(Kq)
Set Rng = Sheet2.[A1].Resize(UBound(Kq))
For i = 1 To UBound(Kq) / 8
With Rng(i * 8 - 7).Resize(2).Interior
        .ColorIndex = 36
        .Pattern = xlSolid
End With
With Rng(i * 8 - 2).Resize(3).Interior
        .ColorIndex = 36
        .Pattern = xlSolid
End With
Rng(i * 8 - 5).Resize(3).Font.ColorIndex = 44
Rng(i * 8 - 5).Characters(8, 5).Font.ColorIndex = 10
Rng(i * 8 - 4).Characters(14, Len(Rng(i * 8 - 4)) - 24).Font.ColorIndex = 5
Rng(i * 8 - 3).Characters(10, Len(Rng(i * 8 - 3)) - 16).Font.ColorIndex = 7
Next
End Sub

Được rồi bác ạ, cái này nó hơi rắc rối nên em làm phiền hơi nhiều. tranh thủ buổi tối rảnh rỗi nên học hỏi anh em

tuan206791 · 27/5/11

Giúp em thêm cái ví dụ này ( Hết lần này sẽ không dám làm phiền các bác nữa)
VD1 Làm cho sheet S1 khi chạy macro có thể ra kqua như ở sheet kqua. (hiện tại thì sheet S2 đang chạy được nhưng em thay dữ liệu ở sheet S1 vào thì không được)
Bỏ tô màu và kẻ ô ở tên ca sỹ ở sheet "kqua" thay vì đó kẻ ô các bài hát em có làm vi du trong file kèm
VD2
mình đã ghi chú thích trong file đi kèm, nhờ các bạn giúp

concogia · 27/5/11

tuan206791 đã viết:
Giúp em thêm cái ví dụ này ( Hết lần này sẽ không dám làm phiền các bác nữa)
VD1 Làm cho sheet S1 khi chạy macro có thể ra kqua như ở sheet kqua. (hiện tại thì sheet S2 đang chạy được nhưng em thay dữ liệu ở sheet S1 vào thì không được)
Bỏ tô màu và kẻ ô ở tên ca sỹ ở sheet "kqua" thay vì đó kẻ ô các bài hát em có làm vi du trong file kèm
VD2
mình đã ghi chú thích trong file đi kèm, nhờ các bạn giúp

Hihi, sao bạn này gởi bài lung tung "zị"
Ví dụ 1 dùng code này ( chưa hiểu đề bài lắm

PHP:

Private Sub Worksheet_Activate()
    Application.ScreenUpdating = False
    Dim Vung, Chon, I, Ws, iDau, iCuoi, iHang
    Set Ws = Sheets("S1")
    Set Vung = Ws.Range(Ws.[a1], Ws.[a10000].End(xlUp))
    [a4:d10000].Delete
        For I = 3 To Vung.Rows.Count
            If Vung(I) <> vbNullString And Vung(I - 1) = vbNullString Then iDau = I
            If Vung(I) = vbNullString And Vung(I - 1) <> vbNullString Then
                iCuoi = I - 1
                iHang = Int((iCuoi + 1 - iDau) / 2) + ((iCuoi + 1 - iDau) Mod 2)
                    With [a10000].End(xlUp)(4)
                        .Resize(iHang, 2).Value = Ws.Range(Ws.Cells(iDau, 1), Ws.Cells(iDau + iHang, 1)).Resize(, 2).Value
                        .Offset(, 2).Resize(iHang - ((iCuoi + 1 - iDau) Mod 2), 2).Value = Ws.Range(Ws.Cells(iDau + iHang, 1), Ws.Cells(iCuoi, 1)).Resize(, 2).Value
                        .Resize(iHang).NumberFormat = "00000"
                        .Resize(iHang).Offset(, 2).NumberFormat = "00000"
                    End With
            [a10000].End(xlUp)(2).Offset(-iHang).Resize(iHang, 4).Select
        With Selection.Borders
            .LineStyle = xlContinuous
            .Weight = xlThin
            .ColorIndex = xlAutomatic
        End With
    End If
Next I
End Sub

Nhập dữ liệu ở sheet S1, chọn sheet1 xem kết quả
Ví dụ 2 thì "chơi" code này

PHP:

Private Sub Worksheet_Activate()
    Dim Vung, I, Mg(), K
    [a1].CurrentRegion.ClearContents
    Vung = Sheet3.Range(Sheet3.[a1], Sheet3.[a10000].End(xlUp)).Value
    ReDim Mg(1 To UBound(Vung), 1 To 1)
        For I = 1 To UBound(Vung)
            If UCase(Right(Vung(I, 1), 3)) = "MP3" Then
                K = K + 1
                Mg(K, 1) = Vung(I, 1)
            End If
        Next I
    [a1].Resize(K) = Mg
End Sub

Nhập, thêm, xóa, sửa...ở sheet "Du lieu", chọn sheet1 xem kết quả
Thân

sealand · 27/5/11

Bận việc chút, giờ mới xong.

Tạo bảng kê:

Mã:

Sub TaoDS()
Dim Tm, Tm1(), Fs As Boolean, i, j
Dim Vg As Range ', Vg1 As Range
Application.ScreenUpdating = False
Fs = True: S2.Columns("A:D").Clear
Set Vg = Range(S1.[a1], S1.[b65536].End(3))
For i = 1 To S1.[b65536].End(3).Row
If S1.Cells(i, 1) = "" And InStr(1, S1.Cells(i, 2), _
"===") = 0 And S1.Cells(i, 2) <> "" Then
j = j + 3
ReDim Preserve Tm1(1 To 4, 1 To j)
Tm1(1, j - 1) = S1.Cells(i, 2)
Fs = True
'End If
ElseIf S1.Cells(i, 1) <> "" Then
If Fs = True Then
j = j + 1
ReDim Preserve Tm1(1 To 4, 1 To j)
ReDim Preserve Tm1(1 To 4, 1 To j)
Tm1(1, j) = "'" & Format(S1.Cells(i, 1), "00000")
Tm1(2, j) = S1.Cells(i, 2)
Fs = False
Else
Tm1(3, j) = "'" & Format(S1.Cells(i, 1), "00000")
Tm1(4, j) = S1.Cells(i, 2)

Fs = True
End If
End If
Next
For i = 1 To UBound(Tm1, 2)
For j = 1 To 4
S2.Cells(i, j).Value = Tm1(j, i)
Next
With S2.Cells(i, 1).Resize(, 4)
If WorksheetFunction.CountA(.Value) = 1 Then
.Merge
.HorizontalAlignment = xlCenter
End If
End With
With S2.Cells(i, 1).Resize(, 4)
If WorksheetFunction.CountA(.Value) > 1 Then
.Borders(xlEdgeLeft).Weight = xlThin
.Borders(xlEdgeTop).Weight = xlThin
.Borders(xlEdgeBottom).Weight = xlThin
.Borders(xlEdgeRight).Weight = xlThin
.Borders(xlInsideVertical).Weight = xlThin
End If
End With
Next
End Sub

Xoá đề mục:

Mã:

Sub XoaDM()
Dim Cl As Range, Cl1 As Range
Set Cl1 = Sheet1.[a1]
Sheet1.Columns(1).Clear
For Each Cl In Range(Sheet2.[a1], Sheet2.[a65536].End(3))
If InStr(1, Cl, ".mp3") > 0 Then
Cl1.Value = Cl.Value
Set Cl1 = Cl1.Offset(1)
End If
Next
End Sub

Giúp em thêm cái ví dụ này ( Hết lần này sẽ không dám làm phiền các bác nữa)

Sao lại thế, biết đâu giúp nhau 1 chút cũng vui.

Giúp mình tạo 2 macro này với

Thành viên bị đình chỉ hoạt động

/(hông là gì!

Thành viên bị đình chỉ hoạt động

Thành viên bị đình chỉ hoạt động

0901452không62

File đính kèm

Thành viên bị đình chỉ hoạt động

Thành viên bị đình chỉ hoạt động

Thành viên gắn bó

File đính kèm

Thành viên bị đình chỉ hoạt động

Thành viên gắn bó

Thành viên bị đình chỉ hoạt động

/(hông là gì!

Thành viên bị đình chỉ hoạt động

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

Thành viên gạo cội

File đính kèm

Thành viên gạo cội

Thành viên bị đình chỉ hoạt động

Thành viên bị đình chỉ hoạt động

Gội rồi mới Cạo

File đính kèm

Thành viên gạo cội

File đính kèm

Đếm ngược thời gian