Làm Một danh sách Excel tùy biến từ một danh sách có sẵn! (4 người xem)

tqcuong · 13/4/10

Mình đang muốn làm 1 danh sách excel từ một danh sách có sẵn mình có làm mẫu nhưng không thể nào làm được, bạn nào giúp mình với!
Các bạn xem file đính kèm nhe

thanh_tks · 13/4/10

tqcuong đã viết:
Mình đang muốn làm 1 danh sách excel từ một danh sách có sẵn mình có làm mẫu nhưng không thể nào làm được, bạn nào giúp mình với!
Các bạn xem file đính kèm nhe

TRong khi đợi chờ cách hay hơn hãy xem tạm file này xem sao!

SA_DQ · 14/4/10

Hãy xem VBA làm điều ấy như thế nào cho bạn

PHP:

Option Explicit

Sub CopyTo()
 Dim Sh As Worksheet, Clls As Range, Rng As Range, nRng As Range, Cell_ As Range
 Dim cTh As String
 
 Sheets("Temp").Select:             Set Sh = Sheets("Ds")
 Sh.[B4].CurrentRegion.Offset(1).ClearContents
 Set Rng = Range([D3], [D3].End(xlToRight))
 For Each Clls In Rng
   Set nRng = Range(Clls.Offset(2), Cells(65500, Clls.Column).End(xlUp))
   For Each Cell_ In nRng
      If UCase$(Cell_.Value) = "X" Then
         With Sh.[A65500].End(xlUp).Offset(1)
            .Value = Clls.Value
            
            cTh = Right(Clls.Offset(1).Value, 1)
            If cTh = "N" Then cTh = "1"
            Select Case cTh
            Case "2", "3"
               .Offset(, 1).Value = IIf(cTh = "2", "hai", "ba")
            Case Else
               ThuVN .Offset(, 1), CByte(cTh)
            End Select
            
            .Offset(, 2).Value = "'" & Right("0000" & Cells(Cell_.Row, "C").Value, 5)
            .Offset(, 3).Value = Cells(Cell_.Row, "B").Value
            
         End With
      End If
   Next Cell_
 Next Clls
End Sub

Mã:

[B]Sub ThuVN(Rng As Range, Thu As Byte)[/B]
 Rng.FormulaR1C1 = Switch(Thu = 4, "=Tu", Thu = 5, "=Nam", _
   Thu = 6, "=Sau", Thu = 7, "=Bay", Thu = 1, "=CNh")
[B]End Sub[/B]

ndu96081631 · 14/4/10

SA_DQ đã viết:

PHP:

Option Explicit

Sub CopyTo()
 Dim Sh As Worksheet, Clls As Range, Rng As Range, nRng As Range, Cell_ As Range
 Dim cTh As String
 
 Sheets("Temp").Select:             Set Sh = Sheets("Ds")
 Sh.[B4].CurrentRegion.Offset(1).ClearContents
 Set Rng = Range([D3], [D3].End(xlToRight))
 For Each Clls In Rng
   Set nRng = Range(Clls.Offset(2), Cells(65500, Clls.Column).End(xlUp))
   For Each Cell_ In nRng
      If UCase$(Cell_.Value) = "X" Then
         With Sh.[A65500].End(xlUp).Offset(1)
            .Value = Clls.Value
            
            cTh = Right(Clls.Offset(1).Value, 1)
            If cTh = "N" Then cTh = "1"
            Select Case cTh
            Case "2", "3"
               .Offset(, 1).Value = IIf(cTh = "2", "hai", "ba")
            Case Else
               ThuVN .Offset(, 1), CByte(cTh)
            End Select
            
            .Offset(, 2).Value = "'" & Right("0000" & Cells(Cell_.Row, "C").Value, 5)
            .Offset(, 3).Value = Cells(Cell_.Row, "B").Value
            
         End With
      End If
   Next Cell_
 Next Clls
End Sub

Mã:

[B]Sub ThuVN(Rng As Range, Thu As Byte)[/B]
 Rng.FormulaR1C1 = Switch(Thu = 4, "=Tu", Thu = 5, "=Nam", _
   Thu = 6, "=Sau", Thu = 7, "=Bay", Thu = 1, "=CNh")
[B]End Sub[/B]

Em dùng 1 vòng lập, không biết tốc độ thế nào:

PHP:

Sub Transfer()
  Dim Sh1 As Worksheet, Sh2 As Worksheet, Clls As Range, DesRng As Range
  Application.ScreenUpdating = False
  Set Sh1 = Sheets("Temp"): Set Sh2 = Sheets("Ds")
  Sh2.Range("A5:D1000").ClearContents
  For Each Clls In Sh1.Range(Sh1.[B5], Sh1.[B65536].End(xlUp))
    On Error GoTo NextStp
    With Clls.Offset(, 2).Resize(, 31).SpecialCells(2)
      Set DesRng = Sh2.Range("A65536").End(xlUp).Offset(1)
      Union(.Cells, Intersect(.EntireColumn, Sh1.[D3:AH3])).Copy
      DesRng.PasteSpecial 3, , , True
      With Range(DesRng, Sh2.Range("A65536").End(xlUp))
        .Resize(, 1).Offset(, 1).Value = .Resize(, 1).Value
        .Resize(, 1).Offset(, 2).Value = Clls.Offset(, 1)
        .Resize(, 1).Offset(, 3).Value = Clls
      End With
    End With
NextStp:
  Next
  Application.CutCopyMode = False
  Application.ScreenUpdating = True
End Sub

- Cột Thứ em dùng Custom Format chứ không dùng code hay công thức
- Giảm 1 vòng lập là nhờ PasteSpecial\Transpose

tqcuong · 14/4/10

Như vậy khi em muốn sử dụng thứ mà không có dấu thì phải làm như thế nào: ví dụ sáu => sau, bảy => bay.

ChanhTQ@ · 14/4/10

To NDU

Bảng chấm công thường không nhiều người trong đó; Nên mình nghĩ tốc độ thì thứ iếu.

Nhưng nếu xài fương thức FIND() ở vòng lặp trong (#3) thì sẽ hay hơn tẹo.

Chúc vui!

ndu96081631 · 14/4/10

tqcuong đã viết:
Như vậy khi em muốn sử dụng thứ mà không có dấu thì phải làm như thế nào: ví dụ sáu => sau, bảy => bay.

Thì thay đoạn code này:
.Resize(, 1).Offset(, 1).Value = .Resize(, 1).Value
Thành:
.Resize(, 1).Offset(, 1).Value = Evaluate("Choose(Weekday(" & .Resize(, 1).Address & "),""CN"",""Hai"",""Ba"",""Tu"",""Nam"",""Sau"",""Bay"")")

TrungChinhs · 15/4/10

tqcuong đã viết:
Mình đang muốn làm 1 danh sách excel từ một danh sách có sẵn mình có làm mẫu nhưng không thể nào làm được, bạn nào giúp mình với!
Các bạn xem file đính kèm nhe

Thử với code - kiểu mực hệt

PHP:

Sub Macro1()
  Application.ScreenUpdating = False
    Sheets("Ds").[a5:d1000].ClearContents
    For Each cls In Sheets("temp").[b5:b1000].SpecialCells(2)
        tmp1 = cls(1, 3).Resize(, 31).SpecialCells(2).Address
        tmp2 = Range(tmp1).Cells.Count
        tmp3 = cls.Row - 4
        With Sheets("Ds")
            .[d65536].End(3)(2).Resize(tmp2) = cls
            .[c65536].End(3)(2).Resize(tmp2) = cls(1, 2)
        End With
        With Sheets("temp")
            .Range(tmp1).Offset(-tmp3).Copy: Sheets("Ds").[b65536].End(3)(2).PasteSpecial (3), Transpose:=True
            .Range(tmp1).Offset(-tmp3 - 1).Copy: Sheets("Ds").[a65536].End(3)(2).PasteSpecial (3), Transpose:=True
        End With
    Next
    [d5].Select
    Application.CutCopyMode = False
End Sub

File đính kèm mượn của Ndu

ndu96081631 · 15/4/10

Trung Chinh đã viết:

Thử với code - kiểu mực hệt

PHP:

Sub Macro1()
  Application.ScreenUpdating = False
    Sheets("Ds").[a5:d1000].ClearContents
    For Each cls In Sheets("temp").[b5:b1000].SpecialCells(2)
        tmp1 = cls(1, 3).Resize(, 31).SpecialCells(2).Address
        tmp2 = Range(tmp1).Cells.Count
        tmp3 = cls.Row - 4
        With Sheets("Ds")
            .[d65536].End(3)(2).Resize(tmp2) = cls
            .[c65536].End(3)(2).Resize(tmp2) = cls(1, 2)
        End With
        With Sheets("temp")
            .Range(tmp1).Offset(-tmp3).Copy: Sheets("Ds").[b65536].End(3)(2).PasteSpecial (3), Transpose:=True
            .Range(tmp1).Offset(-tmp3 - 1).Copy: Sheets("Ds").[a65536].End(3)(2).PasteSpecial (3), Transpose:=True
        End With
    Next
    [d5].Select
    Application.CutCopyMode = False
End Sub

File đính kèm mượn của Ndu

Tại sheet Temp, anh thử xóa dữ liệu tại cell M9rồi chạy code xem thế nào nhé
Nói chung là phương thức SpecialCells luôn tiềm ẩn những lỗi rất nghiêm trọng (bắt buộc phải bẩy lỗi mới xong)

tqcuong · 15/4/10

ndu96081631 đã viết:
Thì thay đoạn code này:
.Resize(, 1).Offset(, 1).Value = .Resize(, 1).Value
Thành:
.Resize(, 1).Offset(, 1).Value = Evaluate("Choose(Weekday(" & .Resize(, 1).Address & "),""CN"",""Hai"",""Ba"",""Tu"",""Nam"",""Sau"",""Bay"")")

Anh cho em hỏi cái này nhe! khi sử dụng số mẫu tin nhiều thì khi chạy code nó mất hết, không ra hết quả gì hết "cụ thể em cho chạy với số mẫu tin khoảng 150 mẫu tin và đổi lại tháng thành tháng 3", mình cho chạy code nhiều lần thì cũng xuất hiện lỗi trên. kết quả không có gì hết.

tqcuong · 15/6/10

Các anh chị cho em hỏi nhe!
Khi ta cho chạy code trên sheet Ds khi số lượng dòng vượt quá 999 dòng thì ngày sẽ hiển thị không đúng vậy?

tqcuong · 15/6/10

Các anh chị cho em hỏi nhe!
Khi ta cho chạy code trên sheet Ds khi số lượng dòng vượt quá 999 dòng thì ngày sẽ hiển thị không đúng vậy?

Làm Một danh sách Excel tùy biến từ một danh sách có sẵn! (4 người xem)

Người dùng đang xem chủ đề này

tqcuong

Thành viên mới

File đính kèm

thanh_tks

Khó khăn biết dũng khí.

File đính kèm

SA_DQ

/(hông là gì!

File đính kèm

ndu96081631

Huyền thoại GPE

File đính kèm

tqcuong

Thành viên mới

ChanhTQ@

0901452không62

ndu96081631

Huyền thoại GPE

TrungChinhs

Thành viên tích cực

File đính kèm

ndu96081631

Huyền thoại GPE

tqcuong

Thành viên mới

tqcuong

Thành viên mới

tqcuong

Thành viên mới

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

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

Đếm ngược thời gian