Trộn ô nhưng vẫn lấy được dữ liệu (1 người xem)

[cachabu]

e muốn lọc lấy dữ liệu khi điều kiện là đã bị trộn ô
anh chị nào giỏi lập trinh giúp em với nhé

 

[Quang_Hải]

e muốn lọc lấy dữ liệu khi điều kiện là đã bị trộn ô
anh chị nào giỏi lập trinh giúp em với nhé

Nội dung yêu cầu là lấy dữ liệu từ các ô đã bị trộn, trong khi mở file ra thì dữ liệu được lấy từ dữ liệu chưa trộn rồi trộn lại >>> cốc hiểu

 

[cachabu]

Nội dung yêu cầu là lấy dữ liệu từ các ô đã bị trộn, trong khi mở file ra thì dữ liệu được lấy từ dữ liệu chưa trộn rồi trộn lại >>> cốc hiểu

anh ơi ý là đáp án là bên sheets kết quả đó anh cột C là cố định và tương ứng với loại đó thì liệt kê những code, diển giải, số tiền ra

 

[phucbugis]

e muốn lọc lấy dữ liệu khi điều kiện là đã bị trộn ô
anh chị nào giỏi lập trinh giúp em với nhé

- bạn tải file đính kèm, cho chạy Macro.

- click nút Update tại sheet KET QUA để xem kết quả nhé !

'----
file đính kèm ----> #9

 

[cachabu]

- bạn tải file đính kèm, cho chạy Macro.

- click nút Update tại sheet KET QUA để xem kết quả nhé !

[GPECODE=vb]
Sub SapXepSoLieu()
Dim Answer
Dim ws As Worksheet

Set ws = Sheets("KETQUA")

ws.Select

mSg = mSg & "Xoa' so' lieu vung`: C6:F65000" & " tai. sheet " & ws.Name & vbNewLine & "truoc khi Update"
Answer = MsgBox(mSg, vbYesNo + vbQuestion)
If Answer = vbNo Then Exit Sub
'If Answer = vbYes Then

ws.Range("C6:F65000").Clear 'loai. bo? noi. dung + format cell

With Sheets("DATA")
If .FilterMode Then .ShowAllData 'do Set vung
Set vung = .Range(.Range("B65000").End(xlUp), .Range("B5"))
End With

'copy 2 vung`
vung.Offset(, 3).Copy Destination:=ws.Range("C6") 'cot. Group
vung.Resize(, 3).Copy Destination:=ws.Range("D6") 'Code, dien giai, So tien
'sort A->Z cot Group
With Range(Range("C65000").End(xlUp), Range("F5"))
.Sort key1:=Range("C5"), order1:=xlAscending, Header:=xlYes
End With
'tron. o^ (cot Group)
Call MergeSameCell(Range([C65000].End(xlUp), [C5])) 'bao gom` Header

Set ws = Nothing: Set vung = Nothing
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
[/GPECODE]

anh ơi, có cách nào để cột C cố định và chỉ upload dữ liệu mấy cột kia thôi được không anh, trường hợp nếu như cột code có thể nhiều hơn 8 dòng thì có thể insert ra thêm dòng được không?

 

[Quang_Hải]

anh ơi ý là đáp án là bên sheets kết quả đó anh cột C là cố định và tương ứng với loại đó thì liệt kê những code, diển giải, số tiền ra

Thử code này luôn coi sao

Sub GetDataMerged()
Application.DisplayAlerts = False
Dim Sh As Worksheet, tam, nguon(), i
Set Sh = Sheets("KETQUA")
Sheets("DATA").[B4:H10000].AdvancedFilter 2, , Sh.[C5:F5], 0
Sh.Range(Sh.[C5], Sh.[F10000].End(3)).Sort [C5], Header:=1
nguon = Sh.Range(Sh.[C5], Sh.[C10000].End(3))
    With CreateObject("scripting.dictionary")
        For i = 2 To UBound(nguon)
          If Not .exists(nguon(i, 1)) Then .Add nguon(i, 1), ""
        Next
        tam = .keys
    End With
For i = 0 To UBound(tam)
   With Sh.Range(Sh.[C6], Sh.[C10000].End(3))
      .AutoFilter 1, tam(i)
      .MergeCells = True
      .VerticalAlignment = xlCenter
      .AutoFilter
   End With
Next
Sh.Range(Sh.[C5], Sh.[F10000].End(3)).Borders.Value = 1
Application.DisplayAlerts = tue
End Sub

 

[cachabu]

Thử code này luôn coi sao

Sub GetDataMerged()
Application.DisplayAlerts = False
Dim Sh As Worksheet, tam, nguon(), i
Set Sh = Sheets("KETQUA")
Sheets("DATA").[B4:H10000].AdvancedFilter 2, , Sh.[C5:F5], 0
Sh.Range(Sh.[C5], Sh.[F10000].End(3)).Sort [C5], Header:=1
nguon = Sh.Range(Sh.[C5], Sh.[C10000].End(3))
    With CreateObject("scripting.dictionary")
        For i = 2 To UBound(nguon)
          If Not .exists(nguon(i, 1)) Then .Add nguon(i, 1), ""
        Next
        tam = .keys
    End With
For i = 0 To UBound(tam)
   With Sh.Range(Sh.[C6], Sh.[C10000].End(3))
      .AutoFilter 1, tam(i)
      .MergeCells = True
      .VerticalAlignment = xlCenter
      .AutoFilter
   End With
Next
Sh.Range(Sh.[C5], Sh.[F10000].End(3)).Borders.Value = 1
Application.DisplayAlerts = tue
End Sub

cám ơn anh, em chỉ muốn cột C cố định như vậy chứ không muốn chỉ lấy những dòng có data, nếu được a viết giúp em lại nhé, cột C tại sheet kết quả là cố định vậy luôn, hiện tại khoảng cách giữa các mã là 8 dòng,như file gốc của em đưa lên đó.
nếu có thể thì ví dụ: nếu dữ liệu của mỗi loại lớn hơn 8 dòng thì tại sheet kết quả ta insert ra thêm thì nó vẫn hiểu là lấy data của mã này sang

 

[ndu96081631]

e muốn lọc lấy dữ liệu khi điều kiện là đã bị trộn ô
anh chị nào giỏi lập trinh giúp em với nhé

Bài này chỉ cần PivotTable, cái rẹt ra ngay kết quả trong 10s, cập nhật kết quả mới khi data thay đổi luôn
Khỏe re... khỏi code kiết gì ráo

 

[phucbugis]

anh ơi, có cách nào để cột C cố định và chỉ upload dữ liệu mấy cột kia thôi được không anh,
...

theo mình hiểu thì bạn chỉ lọc các giá trị đã cài sẵn tại sheet KETQUA ---> bạn tải file đính kèm xem sao nhé !
tại sheet KETQUA:
- điền giá trị cần lọc vào cột H (cột Loại)
- click Button 1 (AdvFilter and MergeCells) --> xem kết quả.

trường hợp nếu như cột code có thể nhiều hơn 8 dòng thì có thể insert ra thêm dòng được không?

vẫn chưa hiểu chỗ này, có lẽ bạn muốn điền thêm số liệu (thêm row) vào sheet KETQUA ???
điều này có vẻ ko hợp lý:
- vì sheet này chủ yếu để xem (khi Update thì số liệu sẽ bị xóa sạch)
- nếu muốn thêm số liệu thì bạn phải sửa từ gốc (từ sheet DATA) mới đúng chứ ? (tại sheet KETQUA thêm row, thêm số liệu --> sheet DATA ko có hiểu được)

[GPECODE=vb]
Sub Loc_TronCell()
Dim Answer 'Khai bao' bien' cuc. bo. thu? tuc.
Dim ListLoai As Range
Dim MyHeader As Range
Dim x As Integer

Sheets("KETQUA").Select
mSg = mSg & "Xoa' so' lieu vung`: C6:F65000 tai. sheet KETQUA " & vbNewLine & "truoc khi Update"
Answer = MsgBox(mSg, vbYesNo + vbQuestion)
If Answer = vbNo Then Exit Sub
'If Answer = vbYes Then

Range("C6:F65000").Clear 'de? xoa' Borders do lan` loc truoc' do' tao. ra

Set ListLoai = Range(Range("H1000").End(xlUp), Range("H1"))
Set MyHeader = Range("C5:F5")

x = Application.WorksheetFunction.CountBlank(ListLoai)
If x > 0 Then
MsgBox "Tim thay' " & x & " o^ trong'." & vbNewLine & _
"So lieu 1 trong cac' o^ thuoc cot. Loai neu' de? trong' --> se~ loc lay' tat ca?", vbInformation
End If
'dung` co^ng cu. Advanced Filter de? loc.
Sheets("DATA").Range("B4:E65000").AdvancedFilter Action:=xlFilterCopy, _
CriteriaRange:=ListLoai, _
CopyToRange:=MyHeader, _
Unique:=False
'sort A->Z cot LOAI
With Range(Range("C65000").End(xlUp), Range("F5"))
.Sort key1:=Range("C5"), order1:=xlAscending, Header:=xlYes
End With
'tron. o^ (cot LOAI) 'http://www.extendoffice.com/documents/excel/1138-excel-merge-same-value.html
Call MergeSameCell(Range([C65000].End(xlUp), [C5])) 'bao gom` Header

Set ws = Nothing: Set ListLoai = Nothing: Set MyHeader = Nothing
End Sub
[/GPECODE]

Link: https://www.mediafire.com/?ior52uyjbjfwbj4

 

[cachabu]

Bài này chỉ cần PivotTable, cái rẹt ra ngay kết quả trong 10s, cập nhật kết quả mới khi data thay đổi luôn
Khỏe re... khỏi code kiết gì ráo

View attachment 120754

anh có thể hướng dẫn làm bằng phương pháp này được không, em có làm rồi, mà nó không được giống như anh,
có 4 menu trong chức năng này
1.report fiter
2.column labels
3.row labels
4.value

e kéo từng tiêu đề bỏ vào mà nó ko giống của anh, nhờ anh hướng dẫn giúp em nhé
cám ơn anh

 

[ndu96081631]

anh có thể hướng dẫn làm bằng phương pháp này được không, em có làm rồi, mà nó không được giống như anh,
có 4 menu trong chức năng này
1.report fiter
2.column labels
3.row labels
4.value

e kéo từng tiêu đề bỏ vào mà nó ko giống của anh, nhờ anh hướng dẫn giúp em nhé
cám ơn anh

Thao tác bình thường thôi mà bạn:


[video=youtube;Z_EucggSCQQ]https://www.youtube.com/watch?v=Z_EucggSCQQ&feature=youtu.be[/video]

 

[cachabu]

em cám ơn anh nhiều nhé em đã làm được rồi