Giúp Load dữ liệu từ sheet khác, merge cell. (1 người xem)

[levanhoa1977]

Ace giaiphapexcel giúp đỡ lập trình giúp. File đính kèm

1/ Sheet DE NGHI: nhập dữ liệu ngày tháng vào ô A4. Dữ liệu sẽ được load từ sheet CHI TIET theo các cột tương ứng của sheet DE NGHI. Một khách hàng thì có nhiều sản phẩm tương ứng ngày đó. Và Merge cell Cột Tên Khách Hàng giống nhau lại. Kẻ khung bao nếu chưa có kẻ khung.
2/ Sheet CHI TIET: có rất nhiều ngày trong tháng. Dữ liệu lấy qua Sheet tương ứng với cột ngày đó. Một ngày có thể có một hay nhiều khách hàng ( không biết trước được).
Mong ace giúp đỡ, Và xin chân thành cảm ơn.

 

[phucbugis]

Ace giaiphapexcel giúp đỡ lập trình giúp. File đính kèm...

bạn tải file đính kèm, cho chạy Macro.
vào sheet DE NGHI, nhập ngày cần lọc tại ô B4

Sub LocNgay()
Application.ScreenUpdating = False 'tang toc' code
    Call XoaSoLieu
    
    Sheets("CHI TIET").Range("A3:AH65000").AdvancedFilter Action:=xlFilterCopy, _
                                                CriteriaRange:=Range("DeNghi_dkLoc"), _
                                                CopyToRange:=Range("DeNghi_dkPaste"), _
                                                Unique:=False
    
    If Application.WorksheetFunction.CountA(Range("B8:B65000")) >= 1 Then
        'Sort A->Z cot KH + tao. Border
        With Range([B65000].End(xlUp), [H7])
            .Sort key1:=Range("B7"), order1:=xlAscending, Header:=xlYes
            .Borders.LineStyle = xlContinuous
        End With
        
        'tao Merge cells cot ten KH
        Call MergeSameCell(Range([B65000].End(xlUp), [B7])) 'bao gom` Header(number)
    End If
    
Application.ScreenUpdating = True
End Sub

Sub XoaSoLieu()
Dim lngLstRow As Long
    With ActiveSheet
        lngLstRow = .UsedRange.Rows.Count 'de? ko tao ra cac row thua`
        With .Range("A8:H" & lngLstRow)
            .Clear
        End With
    End With
End Sub


Sub MergeSameCell(WorkRng As Range)
'http://www.extendoffice.com/documents/excel/1138-excel-merge-same-value.html
Dim xRows As Integer, Rng As Range

    xRows = WorkRng.Rows.Count
    
    Application.DisplayAlerts = False 'do khi Merger cell -> se~ show 1 msgbox
        For Each Rng In WorkRng.Columns
        'For Each Rng In WorkRng 'error
        For i = 1 To xRows - 1
            For j = i + 1 To xRows
                If Rng.Cells(i, 1).Value <> Rng.Cells(j, 1).Value Then
                Exit For
            End If
            Next
            
            With WorkRng.Parent.Range(Rng.Cells(i, 1), Rng.Cells(j - 1, 1))
                .Merge
                .HorizontalAlignment = xlCenter
                .VerticalAlignment = xlCenter
            End With
            
            i = j - 1
        Next
        Next
    Application.DisplayAlerts = True
End Sub

Link: https://www.mediafire.com/?9n84uv0djux16kf

 

[levanhoa1977]

bạn tải file đính kèm, cho chạy Macro.
vào sheet DE NGHI, nhập ngày cần lọc tại ô B4

Sub LocNgay()
Application.ScreenUpdating = False 'tang toc' code
    Call XoaSoLieu
    
    Sheets("CHI TIET").Range("A3:AH65000").AdvancedFilter Action:=xlFilterCopy, _
                                                CriteriaRange:=Range("DeNghi_dkLoc"), _
                                                CopyToRange:=Range("DeNghi_dkPaste"), _
                                                Unique:=False
    
    If Application.WorksheetFunction.CountA(Range("B8:B65000")) >= 1 Then
        'Sort A->Z cot KH + tao. Border
        With Range([B65000].End(xlUp), [H7])
            .Sort key1:=Range("B7"), order1:=xlAscending, Header:=xlYes
            .Borders.LineStyle = xlContinuous
        End With
        
        'tao Merge cells cot ten KH
        Call MergeSameCell(Range([B65000].End(xlUp), [B7])) 'bao gom` Header(number)
    End If
    
Application.ScreenUpdating = True
End Sub

Sub XoaSoLieu()
Dim lngLstRow As Long
    With ActiveSheet
        lngLstRow = .UsedRange.Rows.Count 'de? ko tao ra cac row thua`
        With .Range("A8:H" & lngLstRow)
            .Clear
        End With
    End With
End Sub


Sub MergeSameCell(WorkRng As Range)
'http://www.extendoffice.com/documents/excel/1138-excel-merge-same-value.html
Dim xRows As Integer, Rng As Range

    xRows = WorkRng.Rows.Count
    
    Application.DisplayAlerts = False 'do khi Merger cell -> se~ show 1 msgbox
        For Each Rng In WorkRng.Columns
        'For Each Rng In WorkRng 'error
        For i = 1 To xRows - 1
            For j = i + 1 To xRows
                If Rng.Cells(i, 1).Value <> Rng.Cells(j, 1).Value Then
                Exit For
            End If
            Next
            
            With WorkRng.Parent.Range(Rng.Cells(i, 1), Rng.Cells(j - 1, 1))
                .Merge
                .HorizontalAlignment = xlCenter
                .VerticalAlignment = xlCenter
            End With
            
            i = j - 1
        Next
        Next
    Application.DisplayAlerts = True
End Sub

Cảm ơn bác, hiện tại đã được như yên cầu. Để test thêm vài trường hợp và có gì phát sinh, nhờ bác chỉ dẫn thêm giúp.