Nhờ viết Sub trình bày lại dữ liệu trong bảng tính

Liên hệ QC
TrungChinhs

TrungChinhs

Thành viên tích cực
Tham gia
18/2/08
Bài viết
1,475
Được thích
2,469
Nghề nghiệp
Công chức
Chào các bạn! Trước đây tôi có tạo một kiểu bảng dữ liệu nguồn nhưng để nay cần thay đổi lại cách trình bày dữ liệu để vận dụng một số Sub trên GPE cho việc tự động hoá bảng tính (mẫu biểu và yêu cầu cụ thể trong file đính kèm). Nhờ các Bạn viết code giùm. Xin cảm ơn!
 

File đính kèm

Sắp xếp theo thời gian sắp xếp theo bầu chọn
Sắp xếp lại dữ liệu sao ko dùng Pivot Table hả bạn. Các bài viết về Pivot Table sẽ có ích cho bạn đó.
 
Upvote 0
Bạn kiểm lại & viết thêm về số TT mới, nha!

PHP: 
Option Explicit
Sub ChuyenDoiDuLieu()
 Dim lRow As Long, lChuHo As Long
 Dim cRng As Range
 Application.ScreenUpdating = False
 Columns("C:C").Select:           Selection.Insert Shift:=xlToRight
 [C1] = "NhanKhau":                 lRow = [b65500].End(xlUp).Row
 Range("A3:A" & lRow).SpecialCells(xlCellTypeConstants, 1).Select
 Selection.EntireRow.Insert
  lRow = [b65500].End(xlUp).Row:          lChuHo = 2
  Do
   If lChuHo > lRow Then Exit Do
   Set cRng = Cells(lChuHo, "B").End(xlDown)
   Range(Cells(lChuHo, "B").Offset(1, 1), Cells(cRng.Row, "B").Offset(1, 1)) _
      = Range(Cells(lChuHo, "B"), Cells(cRng.Row, "B")).Value
   Range(Cells(lChuHo + 1, "B"), cRng).Value = ""
   Range(Cells(lChuHo, "B").Offset(1, 2), cRng.Offset(1, 3)) = _
      Range(Cells(lChuHo, "B").Offset(, 2), cRng.Offset(, 3)).Value
   Cells(lChuHo, "B").Offset(, 2).Resize(, 2).Value = ""
   lChuHo = cRng.Row + 2
  Loop
  
End Sub

Một điểm cần chú ý nữa là nếu hộ chỉ 1 nhân khẩu sẽ sai; Nhưng do bạn không đưa ra trong ví dụ về hộ 1 nhân khẩu, nên chưa viết trong macro (!)
Thứ đến: Trước khi cho macro chạy, bạn phải copy từ bản lưu sang sheet nào đó & tại đó ta réo macro ra!

Chúc vui!!
 

File đính kèm

Upvote 0
HYen17 đã viết:
PHP: 
Option Explicit
Sub ChuyenDoiDuLieu()
 Dim lRow As Long, lChuHo As Long
 Dim cRng As Range
 Application.ScreenUpdating = False
 Columns("C:C").Select:           Selection.Insert Shift:=xlToRight
 [C1] = "NhanKhau":                 lRow = [b65500].End(xlUp).Row
 Range("A3:A" & lRow).SpecialCells(xlCellTypeConstants, 1).Select
 Selection.EntireRow.Insert
  lRow = [b65500].End(xlUp).Row:          lChuHo = 2
  Do
   If lChuHo > lRow Then Exit Do
   Set cRng = Cells(lChuHo, "B").End(xlDown)
   Range(Cells(lChuHo, "B").Offset(1, 1), Cells(cRng.Row, "B").Offset(1, 1)) _
      = Range(Cells(lChuHo, "B"), Cells(cRng.Row, "B")).Value
   Range(Cells(lChuHo + 1, "B"), cRng).Value = ""
   Range(Cells(lChuHo, "B").Offset(1, 2), cRng.Offset(1, 3)) = _
      Range(Cells(lChuHo, "B").Offset(, 2), cRng.Offset(, 3)).Value
   Cells(lChuHo, "B").Offset(, 2).Resize(, 2).Value = ""
   lChuHo = cRng.Row + 2
  Loop
  
End Sub
Một điểm cần chú ý nữa là nếu hộ chỉ 1 nhân khẩu sẽ sai; Nhưng do bạn không đưa ra trong ví dụ về hộ 1 nhân khẩu, nên chưa viết trong macro (!)
Thứ đến: Trước khi cho macro chạy, bạn phải copy từ bản lưu sang sheet nào đó & tại đó ta réo macro ra!

Chúc vui!!
Nhấp chuột vào đây để mở rộng...

Cảm ơn Bác ! đúng là có một số trường hợp hộ chỉ có một người (hộ độc thân) khi gửi bài em không nghĩ đến vậy mong Bác tiếp tục giúp đỡ (em đang chờ trên máy). Cảm ơn Bác nhiều !
 
Upvote 0
Trung Chinh đã viết:
Cảm ơn Bác ! đúng là có một số trường hợp hộ chỉ có một người (hộ độc thân) khi gửi bài em không nghĩ đến vậy mong Bác tiếp tục giúp đỡ (em đang chờ trên máy). Cảm ơn Bác nhiều !
Nhấp chuột vào đây để mở rộng...

PHP: 
Option Explicit
Sub ChuyenDoiDuLieu()
 Dim lRow As Long, lChuHo As Long
 Dim cRng As Range
 Application.ScreenUpdating = False
 Columns("C:C").Select:           Selection.Insert Shift:=xlToRight
 [C1] = "NhanKhau":                 lRow = [b65500].End(xlUp).Row
 Set cRng = Range("A3:A" & lRow).SpecialCells(xlCellTypeConstants, 1)
 For lChuHo = 3 To lRow + cRng.Count
   If Cells(lChuHo, "A").Value <> "" Then
      Cells(lChuHo, "A").EntireRow.Insert
      lChuHo = 1 + lChuHo
   End If
 Next lChuHo
  lRow = [b65500].End(xlUp).Row:          lChuHo = 2
  Do
   If lChuHo > lRow Then Exit Do
 
   If Cells(lChuHo + 1, "B") <> "" Then
      Set cRng = Cells(lChuHo, "B").End(xlDown)
 
      Range(Cells(lChuHo, "B").Offset(1, 1), Cells(cRng.Row, "B").Offset(1, 1)) _
         = Range(Cells(lChuHo, "B"), Cells(cRng.Row, "B")).Value
      Range(Cells(lChuHo + 1, "B"), cRng).Value = ""
      Range(Cells(lChuHo, "B").Offset(1, 2), cRng.Offset(1, 3)) = _
         Range(Cells(lChuHo, "B").Offset(, 2), cRng.Offset(, 3)).Value
      Cells(lChuHo, "B").Offset(, 2).Resize(, 2).Value = ""
      lChuHo = cRng.Row + 2
   Else
      Cells(lChuHo + 1, "C") = Cells(lChuHo, "B").Value
      Cells(lChuHo + 1, "D").Resize(, 2) = Cells(lChuHo, "D").Resize(, 2).Value
      Cells(lChuHo, "D").Resize(, 2).Value = ""
      lChuHo = lChuHo + 2
   End If
  Loop
End Sub

Chắc đợi đã lâu & Không thể nhanh hơn! Do lão hóa í mà!
 
Upvote 0
Đường vòng nhưng ngắn hơn; Ngắn hơn chưa hẵn nhanh hơn

Mời các bạn ngâm cứu biến thể của macro trên, như sau:
PHP: 
Option Explicit
Sub ChuyenDoiDuLieu()
 Dim lRow As Long, lChuHo As Long
 Dim cRng As Range

 Application.ScreenUpdating = False
 Columns("C:C").Select:           Selection.Insert Shift:=xlToRight
 [C1] = "NhanKhau":                 lRow = [b65500].End(xlUp).Row
 Set cRng = Range("A3:A" & lRow).SpecialCells(xlCellTypeConstants, 1)
 For lChuHo = 3 To lRow + cRng.Count
   If Cells(lChuHo, "A").Value <> "" Then
      Cells(lChuHo, "A").EntireRow.Insert
      lChuHo = 1 + lChuHo
   End If
 Next lChuHo
 lRow = [b65500].End(xlUp).Row:          lChuHo = 2
 Do
   If lChuHo > lRow Then Exit Do
   With Cells(lChuHo, "B")
      If .Offset(1) <> "" Then
         Set cRng = .End(xlDown)
      Else
         Set cRng = Cells(lChuHo, "B")
      End If
      Range(.Offset(1, 1), Cells(cRng.Row, "B").Offset(1, 1)) _
         = Range(Cells(lChuHo, "B"), Cells(cRng.Row, "B")).Value
      Range(.Offset(1, 2), cRng.Offset(1, 3)) = _
         Range(.Offset(, 2), cRng.Offset(, 3)).Value
      Range(.Offset(1), cRng).Value = ""
      .Offset(, 2).Resize(, 2).Value = ""
      lChuHo = cRng.Row + 2
   End With
 Loop
End Sub
 
Upvote 0
SA_DQ đã viết:
Mời các bạn ngâm cứu biến thể của macro trên, như sau:
PHP: 
Option Explicit
Sub ChuyenDoiDuLieu()
 Dim lRow As Long, lChuHo As Long
 Dim cRng As Range

 Application.ScreenUpdating = False
 Columns("C:C").Select:           Selection.Insert Shift:=xlToRight
 [C1] = "NhanKhau":                 lRow = [b65500].End(xlUp).Row
 Set cRng = Range("A3:A" & lRow).SpecialCells(xlCellTypeConstants, 1)
 For lChuHo = 3 To lRow + cRng.Count
   If Cells(lChuHo, "A").Value <> "" Then
      Cells(lChuHo, "A").EntireRow.Insert
      lChuHo = 1 + lChuHo
   End If
 Next lChuHo
 lRow = [b65500].End(xlUp).Row:          lChuHo = 2
 Do
   If lChuHo > lRow Then Exit Do
   With Cells(lChuHo, "B")
      If .Offset(1) <> "" Then
         Set cRng = .End(xlDown)
      Else
         Set cRng = Cells(lChuHo, "B")
      End If
      Range(.Offset(1, 1), Cells(cRng.Row, "B").Offset(1, 1)) _
         = Range(Cells(lChuHo, "B"), Cells(cRng.Row, "B")).Value
      Range(.Offset(1, 2), cRng.Offset(1, 3)) = _
         Range(.Offset(, 2), cRng.Offset(, 3)).Value
      Range(.Offset(1), cRng).Value = ""
      .Offset(, 2).Resize(, 2).Value = ""
      lChuHo = cRng.Row + 2
   End With
 Loop
End Sub
Nhấp chuột vào đây để mở rộng...

To Bác HYen và Bác SA_DQ: đoạn Code của Bác HYen thì cho kết quả đúng nhưng Cde của Bác SA_DQ có 1 lỗi là khi hộ chỉ có 1 người (hộ độc thân) thì cột chủ hộ sẽ không có tên

Nhờ các Bác chỉ giúp lỗi đó ở chỗ nào. Thanks !
 
Lần chỉnh sửa cuối:
Upvote 0
Một cách khác, trong khi tìm cách khắc phục lỗi

Dùng chủ yếu phương thức .Cut

PHP: 
Option Explicit
Sub ChuyenDuLieu()
 Dim lRow As Long, lChuHo As Long, lZz As Long
 Dim cRng As Range:                       Dim sChuHo As String

 Application.ScreenUpdating = False
 Range([d1], [e1]) = Range([c1], [d1]).Value
 [c1] = "NhanKhau":                 lRow = [b65500].End(xlUp).Row
 Set cRng = Range("A3:A" & lRow).SpecialCells(xlCellTypeConstants, 1)
 
 For lChuHo = 3 To lRow + cRng.Count
   If Cells(lChuHo, "A").Value <> "" Then
      Cells(lChuHo, "A").EntireRow.Insert
      lChuHo = 1 + lChuHo
   End If
 Next lChuHo
 lRow = [b65500].End(xlUp).Row:           lChuHo = 2
 Do
   If lChuHo > lRow Then Exit Do
   With Cells(lChuHo, "B")
      sChuHo = .Value
      If .Offset(1) <> "" Then
         lZz = .End(xlDown).Row
         Set cRng = .Offset().Resize(1 + lZz - .Row, 3)
      Else
         Set cRng = .Offset().Resize(, 3)
         lZz = .Row
      End If
      cRng.Cut:                           .Offset(1, 1).Select
      ActiveSheet.Paste
      Cells(lChuHo, "B") = sChuHo  '<<=='
      lChuHo = lZz + 2
   End With
 Loop
End Sub

Nhưng lại phát sinh vấn đề ngoài lề tại lệnh sau .Cut
 
Upvote 0
Cải thiện tốc độ lần sau cùng

Thay vì duyệt qua toàn bộ từng nhân khẩu, ta chỉ duyệt các chủ hộ mà thôi:
PHP: 
Option Explicit
Sub ChuyenDuLieu()
 Dim lRow As Long, lChuHo As Long, lZz As Long
 Dim cRng As Range, RLe As Range, RCh As Range
 Dim sChuHo As String

 Application.ScreenUpdating = False
 Range([d1], [e1]) = Range([c1], [d1]).Value
 [c1] = "NhanKhau":                       lRow = [b65500].End(xlUp).Row
 For Each cRng In Range("A3:A" & lRow).SpecialCells(xlCellTypeConstants, 1)
   If cRng.Row Mod 2 = 1 Then
      If RCh Is Nothing Then
         Set RCh = cRng
      Else
         Set RCh = Union(RCh, cRng)
      End If
   Else
      If RLe Is Nothing Then
         Set RLe = cRng
      Else
         Set RLe = Union(RLe, cRng)
      End If
   End If
 Next cRng
 RLe.EntireRow.Insert:                    Set RLe = Nothing
 RCh.EntireRow.Insert:                    Set RCh = Nothing
 lRow = [b65500].End(xlUp).Row:           lChuHo = 2
 Do
   If lChuHo > lRow Then Exit Do
   With Cells(lChuHo, "B")
      sChuHo = .Value
      If .Offset(1) <> "" Then
         lZz = .End(xlDown).Row
         Set cRng = .Offset().Resize(1 + lZz - .Row, 3)
      Else
         Set cRng = .Offset().Resize(, 3)
         lZz = .Row
      End If
      cRng.Cut Destination:=.Offset(1, 1)
      Application.CutCopyMode = False
      Cells(lChuHo, "B") = sChuHo  '<<=='
      lChuHo = lZz + 2
   End With
 Loop
End Sub
 
Upvote 0
Mã: 
Option Explicit
Sub ChuyenDuLieu()
 Dim lRow As Long, lChuHo As Long, lZz As Long
 Dim cRng As Range, RLe As Range, RCh As Range
 Dim sChuHo As String
 
 Application.ScreenUpdating = False
 Range([d1], [e1]) = Range([c1], [d1]).Value
 [c1] = "NhanKhau":                       lRow = [b65500].End(xlUp).Row
 For Each cRng In Range("A3:A" & lRow).SpecialCells(xlCellTypeConstants, 1)
   If cRng.Row Mod 2 = 1 Then
      If RCh Is Nothing Then
         Set RCh = cRng
      Else
         Set RCh = Union(RCh, cRng)
      End If
   Else
      If RLe Is Nothing Then
         Set RLe = cRng
      Else
         Set RLe = Union(RLe, cRng)
      End If
   End If
 Next cRng
 RLe.EntireRow.Insert:                    Set RLe = Nothing
 RCh.EntireRow.Insert:                    Set RCh = Nothing
 lRow = [b65500].End(xlUp).Row:           lChuHo = 2
 Do
   If lChuHo > lRow Then Exit Do
   With Cells(lChuHo, "B")
      sChuHo = .Value
      If .Offset(1) <> "" Then
         lZz = .End(xlDown).Row
         Set cRng = .Offset().Resize(1 + lZz - .Row, 3) [COLOR=royalblue]'<<===[/COLOR]
      Else
         Set cRng = .Offset().Resize(, 3) [COLOR=royalblue]'<<===[/COLOR]
         lZz = .Row
      End If
      cRng.Cut Destination:=.Offset(1, 1)
      Application.CutCopyMode = False
      Cells(lChuHo, "B") = sChuHo  [COLOR=royalblue]'<<=='[/COLOR]
      lChuHo = lZz + 2
   End With
 Loop
End Sub
Các bác giải thích cho em rõ ở chỗ: (Các dòng lệnh em đã tô màu xanh phía trên)
.Offset() có phải/ có thể thay bằng .Offset(0,0) được không
Và Dòng Cells(lChuHo, "B") = sChuHo
Sao lại không thay được bằng .Offset() = sChuHo hay .Offset(0,0) = sChuHo ?
Xin cảm ơn trước, các bác nhé! Rất cảm ơn!
 
Lần chỉnh sửa cuối:
Upvote 0
ChanhTQ@ đã viết:
Các bác giải thích cho em rõ ở chỗ: (Các dòng lệnh em đã tô màu xanh phía trên)
.Offset() có phải/ có thể thay bằng .Offset(0,0) được không
Nhấp chuột vào đây để mở rộng...
Tôi nghĩ là đúng vậy đấy! (thí nghiệm)... Nhưng không hiểu là tại sao lại không bỏ luôn nó nhỉ (cho Offset() vào nhằm mục đích gì?)
Ví dụ:
Set cRng = .Offset().Resize(1 + lZz - .Row, 3)
Nhấp chuột vào đây để mở rộng...
thì tại sao không là:
Set cRng = .Resize(1 + lZz - .Row, 3)
Nhấp chuột vào đây để mở rộng...
ChanhTQ@ đã viết:
Và Dòng Cells(lChuHo, "B") = sChuHo
Sao lại không thay được bằng .Offset() = sChuHo hay .Offset(0,0) = sChuHo ?
Nhấp chuột vào đây để mở rộng...
Còn tôi thì cho rằng tại sao không là :
.Value = sChuHo
Nhấp chuột vào đây để mở rộng...
 
Upvote 0
ndu96081631 đã viết:
Tôi nghĩ là đúng vậy đấy! (thí nghiệm)... Nhưng không hiểu là tại sao lại không bỏ luôn nó nhỉ (cho .Offset() vào nhằm mục đích gì?)
Ví dụ:
Nhấp chuột vào đây để mở rộng...
Đúng là những anh chàng này bỏ được. Mình thử bỏ rồi, không có chuyện gì sẫy ra
thì tại sao không là: .Offset() = sChuHo
Còn tôi thì cho rằng tại sao không là : .Value = sChuHo
Nhấp chuột vào đây để mở rộng...
thì không được bạn à!
Mình thử thêm dòng lệnh MsgBox .Address sau dòng lệnh .Cut, thì được biết rằng cái chàng .Cut nó làm thay đổi địa chỉ các ô trong cRng rồi!

Muốn hiễn thị đúng ý đồ tác giả, ta lại phải ghi
.Offset(-1 , -1) thay vì .Value như bạn hay .Offset(0,0) như mình nghỉ!

Dù gì cũng rất cảm ơn bạn đã quan tâm & có ý kiến!
 
Upvote 0
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

N
Cách đánh số thứ tự không liên tục (đánh số lại từ đầu khi cột bên cạnh có giá trị)
Trả lời
5
Đọc
52
HieuCD
H
G
Chuyển Data từ hàng và cột về dạng cột
Trả lời
11
Đọc
136
ptm0412
ptm0412
quangminhici
Tặng Addin Word xuất Mail Merge có chức năng cắt ra nhiều file và gửi mail.
    • Thích
    • Yêu thích
Trả lời
16
Đọc
2K
quyenpv
quyenpv
P
Tại sao khi đánh số thì bị mất hai số cuối
Trả lời
4
Đọc
18K
vanle33
vanle33
HeSanbi
  • Đã giải quyết
LocalizeXL v1.71 - Làm nổi bật ô đang chọn và cuộn trang tự động
    • Thích
    • Yêu thích
2 3
Trả lời
58
Đọc
9K
HeSanbi
HeSanbi
vanle33
File không thao tác gì khi mở ra vẫn hỏi lưu lại khi tắt đi.
Trả lời
5
Đọc
73
zzzsxxx01
Z
linhvu2807
Lỗi hàm công thức Querry
Trả lời
0
Đọc
31
linhvu2807
linhvu2807
C
Tìm dữ liệu khác nhau trong 2 file hoặc 2 sheet trong excel
Trả lời
2
Đọc
119
HUONGHCKT
H
D
Paste dữ liệu, bỏ qua các cell ẩn
2
Trả lời
30
Đọc
45K
HUONGHCKT
H
phatnguyen7301
  • Question Question
Tạo âm thanh khi nhấn vào một phím
Trả lời
3
Đọc
138
yaaasoo01
Y
GPE-Trợ Lý
[GPE] TALK SHOW HÀM QUERY - BÍ KÍP BIẾN DỮ LIỆU KHỔNG LỒ THÀNH THÔNG TIN HỮU ÍCH TRONG TÍCH TẮC
    • Thích
    • Yêu thích
Trả lời
0
Đọc
613
GPE-Trợ Lý
GPE-Trợ Lý
B
Xin hàm đếm số lượng khách hàng theo 1 điều kiện và bỏ dữ liệu trùng.
Trả lời
11
Đọc
460
bipbo2008
B
HeSanbi
  • Question Question
VBA Nâng cao: Hướng dẫn tạo biểu thức tìm kiếm với Regular Expression
    • Thích
    • Yêu thích
Trả lời
2
Đọc
235
HeSanbi
HeSanbi
NguyenthiH
Sao dùng Ctl + H thay thế không đúng.
Trả lời
19
Đọc
257
NguyenthiH
NguyenthiH
N
Lỗi định dạng số Excel 2019 - Nguyên nhân và cách khắc phục
Trả lời
1
Đọc
45
ptm0412
ptm0412
huuthang_bd
Chia sẻ: Tạo thông báo nhắc nhở khi sắp đến ngày kỷ niệm
    • Thích
    • Yêu thích
2
Trả lời
39
Đọc
9K
ngocminhkte
ngocminhkte
HeSanbi
  • Đã giải quyết
ExcelController - Các hàm thực thi tác vụ linh hoạt cho Excel
    • Thích
    • Yêu thích
Trả lời
5
Đọc
1K
HeSanbi
HeSanbi
LuuAnh980
Add in tạo QR code miễn phí.
Trả lời
10
Đọc
242
HUONGHCKT
H
V
Xin giúp em file theo dõi thanh toán có bị quá hạn không, quá bao nhiêu ngày và bao nhiêu tiền ạ
Trả lời
10
Đọc
242
hvnhpro
H
tuv8x
Xin hỏi cách giới hạn vùng làm việc
Trả lời
2
Đọc
92
tuv8x
tuv8x
Xem thêm…

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

000
Ngày
00
Giờ
00
phút
00
giây
Chúc mừng năm mới.
Back
Top Bottom