Merge ô theo điều kiện của một cột và sinh mã tự động.

[nguyen6571gpex]

Chào các bạn!
Mình có file nhân khẩu của một xã, gồm nhiều thôn, mỗi thôn một sheet. Ở mỗi thôn đã nhập dữ liệu bắt đầu là chủ hộ và các thành viên trong hộ, sau đó đến các nhân khẩu của hộ tiếp theo. Mình nhờ các bạn giúp lệnh VBA (khi nhấn lệnh TỔNG HỢP) như sau:
- Coppy lần lượt từng sheet (mỗi sheet là một thôn, tên sheet là ký hiệu thôn) sang sheet TH, sau đó:
- Gộp những người cùng một hộ lại và sinh mã, mã gồm ký hiệu thôn (tên sheet) rồi đến bốn chữ số bắt đầu từ 0001 đến hết thôn. Mỗi hộ được xác định theo cột Quan hệ với chủ hộ, bắt đầu từ chủ hộ và những người dòng kế tiếp đến dòng chủ hộ tiếp theo là của hộ mới.
- Hết thôn thứ nhất đến thôn thứ hai thì ký hiệu mã thay đổi theo tên sheet và bốn chữ số tiếp theo lại bắt đầu từ 0001.
- Vì đây là file mẫu nên số thôn chỉ có 3 thôn thực tế có 9 thôn, mỗi thôn khoảng 2500 nhân khẩu (2500 dòng)
Trân trọng!

 

[BuiQuangThuan]

Trân trọng!

Không hòa ô ở cột tạo mã có được không?

 

[Nhattanktnn]

Chào các bạn!
Mình có file nhân khẩu của một xã, gồm nhiều thôn, mỗi thôn một sheet. Ở mỗi thôn đã nhập dữ liệu bắt đầu là chủ hộ và các thành viên trong hộ, sau đó đến các nhân khẩu của hộ tiếp theo. Mình nhờ các bạn giúp lệnh VBA (khi nhấn lệnh TỔNG HỢP) như sau:
- Coppy lần lượt từng sheet (mỗi sheet là một thôn, tên sheet là ký hiệu thôn) sang sheet TH, sau đó:
- Gộp những người cùng một hộ lại và sinh mã, mã gồm ký hiệu thôn (tên sheet) rồi đến bốn chữ số bắt đầu từ 0001 đến hết thôn. Mỗi hộ được xác định theo cột Quan hệ với chủ hộ, bắt đầu từ chủ hộ và những người dòng kế tiếp đến dòng chủ hộ tiếp theo là của hộ mới.
- Hết thôn thứ nhất đến thôn thứ hai thì ký hiệu mã thay đổi theo tên sheet và bốn chữ số tiếp theo lại bắt đầu từ 0001.
- Vì đây là file mẫu nên số thôn chỉ có 3 thôn thực tế có 9 thôn, mỗi thôn khoảng 2500 nhân khẩu (2500 dòng)
Trân trọng!

Thử code:

Option Explicit

Sub TimDL()
    Dim strSQL As String, R As Long, fID As String, J As Long, CH As String
    Dim i As Integer, Ws As Worksheet, Rws As Long, Rng As Range
    CH = "ch" & ChrW(7911) & " h" & ChrW(7897) 'chu ho
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    For Each Ws In Sheets
        If Ws.Name <> "TH" Then
            strSQL = strSQL & " Union All Select * From [" & Ws.Name & "$B2:H] where F1 is not null"
        End If
    Next
    strSQL = Right(strSQL, Len(strSQL) - 11)
    With CreateObject("ADODB.Recordset")
       .Open "Select * from (" & strSQL & ")", _
       "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties=""Excel 12.0 Xml;HDR=No"";Data Source=" & ThisWorkbook.FullName, 1, 3
       Sheets("TH").Range("B2").Resize(10000, 9).Clear
       Sheets("TH").Range("B2").CopyFromRecordset .DataSource
    End With
    With Sheets("TH")
        Set Rng = .Range("A2:I" & .Cells(Rows.Count, "B").End(xlUp).Row)
        With Rng
            .Font.Color = vbBlack
            .Font.Bold = True
            .Borders.LineStyle = xlContinuous
            .VerticalAlignment = xlCenter
            .Font.Name = "Times New Roman"
            .Font.Size = 12
        End With
        .Cells.UnMerge
        R = 1
        Rws = Rng.Rows.Count
        For i = 1 To Rws
            Rng(i, 1) = i
            If Trim(LCase(Rng(i, "D").Value)) = CH Then
                If Rng(i, 2) <> fID Then fID = Rng(i, 2): J = 1 Else J = J + 1
                Rng(i, 1).Resize(, 8).Font.Color = vbRed
                Rng(i, 9) = fID & Format(J, "0000")
                If i > 1 Then Rng(R, 9).Resize(i - R).Merge
                R = i
            ElseIf i = Rws Then
                Rng(R, 9).Resize(i - R + 1).Merge
            End If
        Next
    End With
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
End Sub

 

[HUONGHCKT]

Chào các bạn!
Mình có file nhân khẩu của một xã, gồm nhiều thôn, mỗi thôn một sheet. Ở mỗi thôn đã nhập dữ liệu bắt đầu là chủ hộ và các thành viên trong hộ, sau đó đến các nhân khẩu của hộ tiếp theo. Mình nhờ các bạn giúp lệnh VBA (khi nhấn lệnh TỔNG HỢP) như sau:
- Coppy lần lượt từng sheet (mỗi sheet là một thôn, tên sheet là ký hiệu thôn) sang sheet TH, sau đó:
- Gộp những người cùng một hộ lại và sinh mã, mã gồm ký hiệu thôn (tên sheet) rồi đến bốn chữ số bắt đầu từ 0001 đến hết thôn. Mỗi hộ được xác định theo cột Quan hệ với chủ hộ, bắt đầu từ chủ hộ và những người dòng kế tiếp đến dòng chủ hộ tiếp theo là của hộ mới.
- Hết thôn thứ nhất đến thôn thứ hai thì ký hiệu mã thay đổi theo tên sheet và bốn chữ số tiếp theo lại bắt đầu từ 0001.
- Vì đây là file mẫu nên số thôn chỉ có 3 thôn thực tế có 9 thôn, mỗi thôn khoảng 2500 nhân khẩu (2500 dòng)
Trân trọng!

Góp vui.
Nhấn vào mặt cười để tận hưởng kết quả.

 

[BuiQuangThuan]

Trân trọng!

Góp thêm 1 cách khác. Lười merge.

Sub ABC()
    Dim Ws As Worksheet, sArr(), Res(), iR&, iRow&, Ma$, STT%, i&, j&
    Sheets("TH").Range("B2:I100000").ClearContents
    For Each Ws In Worksheets
        If Ws.Name <> "TH" Then
            iRow = Ws.Range("B" & Rows.Count).End(3).Row
            sArr = Ws.Range("B2:H" & iRow).Value
            ReDim Res(1 To UBound(sArr), 1 To 8)
            For i = 1 To UBound(sArr)
                If UCase(sArr(i, 3)) = "CH" & ChrW(7910) & " H" & ChrW(7896) Then
                    STT = STT + 1
                    Ma = Ws.Name & Format(STT, "0000")
                End If
                For j = 1 To UBound(sArr, 2)
                    Res(i, j) = sArr(i, j)
                Next
                    Res(i, 8) = Ma
            Next
            With Sheets("TH")
                iR = .Range("B" & Rows.Count).End(3).Row + 1
                .Range("B" & iR).Resize(UBound(sArr), 8).Value = Res
            End With
            STT = 0
        End If
    Next
End Sub

 

[nguyen6571gpex]

Góp vui.
Nhấn vào mặt cười để tận hưởng kết quả.

Bị lỗi này nhờ bạn sửa giúp. Cảm ơn nhiều!

 

[BuiQuangThuan]

Bị lỗi này nhờ bạn sửa giúp. Cảm ơn nhiều!

Khai báo thêm dim d as long

 

[HUONGHCKT]

Bị lỗi này nhờ bạn sửa giúp. Cảm ơn nhiều!

Lỗi này do khai báo biến bị thiếu, tôi không kiểm tra kỹ nên....
Hãy làm theo hướng dẫn của bạn @BuiQuangThuan nhé.
"Khai báo thêm Dim as Long" ở đầu sub
Cảm ơn bạn @BuiQuangThuan đã xem bài.

 

[nguyen6571gpex]

Mình đã giải quyết được công việc. Xin trân trọng cảm ơn tất cả các bạn đã quan tâm giúp đỡ. Trân trọng!