Giúp lọc dữ liệu đưa kết quả vào sheet mới (1 người xem)

  • Thread starter Thread starter d1207t
  • Ngày gửi Ngày gửi
Liên hệ QC

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

Đang trực tuyến: 1 (Thành viên: 0, Khách: 1)
D

d1207t

Thành viên mới
Tham gia
24/11/11
Bài viết
40
Được thích
6
Dear các nah chị diễn đàn em xin giúp đỡ vấn đề sau:
Em có 1 file mà cột B (Phương án) bao gồm một số giá trị cố định. Em muốn có hàm vba nào có thể giúp lọc riêng từng phương án copy toàn bộ giá trị bảng tính (sau khi lọc) của phương án đó ra 1 sheet mới (Sheet mới mang tên phương án).
Như vậy có báo nhiêu phương án thì sẽ có tương ứng số sheets được tạo mới.
Rất mong các anh chị giúp đỡ em vấn đề này.
Trân thành cảm ơn các anh chị.
 

File đính kèm

d1207t đã viết:
Dear các nah chị diễn đàn em xin giúp đỡ vấn đề sau:
Em có 1 file mà cột B (Phương án) bao gồm một số giá trị cố định. Em muốn có hàm vba nào có thể giúp lọc riêng từng phương án copy toàn bộ giá trị bảng tính (sau khi lọc) của phương án đó ra 1 sheet mới (Sheet mới mang tên phương án).
Như vậy có báo nhiêu phương án thì sẽ có tương ứng số sheets được tạo mới.
Rất mong các anh chị giúp đỡ em vấn đề này.
Trân thành cảm ơn các anh chị.
Nhấp chuột vào đây để mở rộng...
Mã: 
Sub TachPhuongAn()
  Dim sArr(), Res()
  Dim eRow&, sR&, sC&, i&, i2&, j&, k&, ikey$
 
  With Sheets("SL")
    eRow = .Range("B" & Rows.Count).End(xlUp).Row
    If eRow < 2 Then Exit Sub
    sArr = .Range("A1:H" & eRow).Value
  End With
  sR = UBound(sArr, 1): sC = UBound(sArr, 2)
  Application.ScreenUpdating = False
  With CreateObject("scripting.dictionary")
    For i = 2 To sR
      ikey = sArr(i, 2)
      If Len(ikey) > 0 Then
        If .exists(ikey) = False Then
          .Add ikey, ""
          ReDim Res(1 To sR, 1 To sC)
          k = 1
          For j = 1 To sC 'Tieu De
            Res(k, j) = sArr(k, j)
          Next j
          For i2 = i To sR 'Loc Du lieu
            If sArr(i2, 2) = ikey Then
              k = k + 1
              For j = 1 To sC
                Res(k, j) = sArr(i2, j)
              Next j
            End If
          Next i2
          For j = 1 To Sheets.Count
            With Sheets(j)
              If .Name = ikey Then
                .UsedRange.ClearContents
                .Range("A1:H" & k) = Res
                Exit For
              End If
            End With
          Next j
          If j > Sheets.Count Then
            Sheets.Add After:=Sheets(Sheets.Count)
            With Sheets(Sheets.Count)
              .Name = ikey
              .Range("A1").Resize(k, sC) = Res
            End With
          End If
        End If
      End If
    Next i
  End With
  Sheets("SL").Select
  Application.ScreenUpdating = True
End Sub
 
d1207t đã viết:
Dear các nah chị diễn đàn em xin giúp đỡ vấn đề sau:
Em có 1 file mà cột B (Phương án) bao gồm một số giá trị cố định. Em muốn có hàm vba nào có thể giúp lọc riêng từng phương án copy toàn bộ giá trị bảng tính (sau khi lọc) của phương án đó ra 1 sheet mới (Sheet mới mang tên phương án).
Như vậy có báo nhiêu phương án thì sẽ có tương ứng số sheets được tạo mới.
Rất mong các anh chị giúp đỡ em vấn đề này.
Trân thành cảm ơn các anh chị.
Nhấp chuột vào đây để mở rộng...
Cách khách cho bạn lựa chọn
Mã: 
Sub tachsheet()
Dim sArr As Variant
Dim i As Long, Lr As Long, Lr1 As Long, ShN As String

Application.ScreenUpdating = False
With Sheets("SL")
    Lr = .Range("A10000").End(xlUp).Row
    sArr = .Range("A2:H" & Lr).Value2
End With
For i = 1 To UBound(sArr)
    If InStr(ShN, sArr(i, 2)) = 0 Then
        ShN = ShN & sArr(i, 2)
        Sheets.Add After:=Sheets(Sheets.Count)
        With ActiveSheet
            .Range("A1").Value = "Phuong An"
            .Range("B1").Value = sArr(i, 2)
            .Range("A2:H2").Value = Sheets("SL").Range("A1:H1").Value
            .Cells.Font.Name = ".VnTime"
            .Name = sArr(i, 2)
        End With
    End If
    With ActiveSheet
        If .Range("B1").Value = sArr(i, 2) Then
            Lr1 = .Range("A10000").End(xlUp).Row + 1
            .Range("A" & Lr1) = sArr(i, 1)
            .Range("B" & Lr1) = sArr(i, 2)
            .Range("C" & Lr1) = sArr(i, 3)
            .Range("D" & Lr1) = sArr(i, 4)
            .Range("E" & Lr1) = sArr(i, 5)
            .Range("F" & Lr1) = sArr(i, 6)
            .Range("G" & Lr1) = sArr(i, 7)
            .Range("H" & Lr1) = sArr(i, 8)
        End If
    End With
Next i
Sheets("SL").Select
Application.ScreenUpdating = True

End Sub
 
nguyenthuy13388 đã viết:
Cách khách cho bạn lựa chọn
Mã: 
Sub tachsheet()
Dim sArr As Variant
Dim i As Long, Lr As Long, Lr1 As Long, ShN As String

Application.ScreenUpdating = False
With Sheets("SL")
    Lr = .Range("A10000").End(xlUp).Row
    sArr = .Range("A2:H" & Lr).Value2
End With
For i = 1 To UBound(sArr)
    If InStr(ShN, sArr(i, 2)) = 0 Then
        ShN = ShN & sArr(i, 2)
        Sheets.Add After:=Sheets(Sheets.Count)
        With ActiveSheet
            .Range("A1").Value = "Phuong An"
            .Range("B1").Value = sArr(i, 2)
            .Range("A2:H2").Value = Sheets("SL").Range("A1:H1").Value
            .Cells.Font.Name = ".VnTime"
            .Name = sArr(i, 2)
        End With
    End If
    With ActiveSheet
        If .Range("B1").Value = sArr(i, 2) Then
            Lr1 = .Range("A10000").End(xlUp).Row + 1
            .Range("A" & Lr1) = sArr(i, 1)
            .Range("B" & Lr1) = sArr(i, 2)
            .Range("C" & Lr1) = sArr(i, 3)
            .Range("D" & Lr1) = sArr(i, 4)
            .Range("E" & Lr1) = sArr(i, 5)
            .Range("F" & Lr1) = sArr(i, 6)
            .Range("G" & Lr1) = sArr(i, 7)
            .Range("H" & Lr1) = sArr(i, 8)
        End If
    End With
Next i
Sheets("SL").Select
Application.ScreenUpdating = True

End Sub
Nhấp chuột vào đây để mở rộng...
em cảm ơn anh nhiều nhé!
Bài đã được tự động gộp:

HieuCD đã viết:
Mã: 
Sub TachPhuongAn()
  Dim sArr(), Res()
  Dim eRow&, sR&, sC&, i&, i2&, j&, k&, ikey$

  With Sheets("SL")
    eRow = .Range("B" & Rows.Count).End(xlUp).Row
    If eRow < 2 Then Exit Sub
    sArr = .Range("A1:H" & eRow).Value
  End With
  sR = UBound(sArr, 1): sC = UBound(sArr, 2)
  Application.ScreenUpdating = False
  With CreateObject("scripting.dictionary")
    For i = 2 To sR
      ikey = sArr(i, 2)
      If Len(ikey) > 0 Then
        If .exists(ikey) = False Then
          .Add ikey, ""
          ReDim Res(1 To sR, 1 To sC)
          k = 1
          For j = 1 To sC 'Tieu De
            Res(k, j) = sArr(k, j)
          Next j
          For i2 = i To sR 'Loc Du lieu
            If sArr(i2, 2) = ikey Then
              k = k + 1
              For j = 1 To sC
                Res(k, j) = sArr(i2, j)
              Next j
            End If
          Next i2
          For j = 1 To Sheets.Count
            With Sheets(j)
              If .Name = ikey Then
                .UsedRange.ClearContents
                .Range("A1:H" & k) = Res
                Exit For
              End If
            End With
          Next j
          If j > Sheets.Count Then
            Sheets.Add After:=Sheets(Sheets.Count)
            With Sheets(Sheets.Count)
              .Name = ikey
              .Range("A1").Resize(k, sC) = Res
            End With
          End If
        End If
      End If
    Next i
  End With
  Sheets("SL").Select
  Application.ScreenUpdating = True
End Sub
Nhấp chuột vào đây để mở rộng...
Em cảm ơn anh nhiều nhé
 
d1207t đã viết:
em cảm ơn anh nhiều nhé!
Bài đã được tự động gộp:


Em cảm ơn anh nhiều nhé
Nhấp chuột vào đây để mở rộng...
bạn dùng Sub này trong trường hợp dữ liệu chưa được sort (không liền kề với nhau
Mã: 
Sub tachsheet()
Dim sArr As Variant, sh As Worksheet
Dim i As Long, Lr As Long, Lr1 As Long, ShN As String

Application.ScreenUpdating = False
With Sheets("SL")
    Lr = .Range("A10000").End(xlUp).Row
    sArr = .Range("A2:H" & Lr).Value2
End With
For i = 1 To UBound(sArr)
    If InStr(ShN, sArr(i, 2)) = 0 Then
        ShN = ShN & sArr(i, 2)
        Sheets.Add After:=Sheets(Sheets.Count)
        With ActiveSheet
            .Range("A1").Value = "Phuong An"
            .Range("B1").Value = sArr(i, 2)
            .Range("A2:H2").Value = Sheets("SL").Range("A1:H1").Value
            .Cells.Font.Name = ".VnTime"
            .Name = sArr(i, 2)
        End With
    End If
    For Each sh In Worksheets
    If sh.Name <> "SL" Then
    With sh
        If .Name = sArr(i, 2) Then
            Lr1 = .Range("A10000").End(xlUp).Row + 1
            .Range("A" & Lr1) = sArr(i, 1)
            .Range("B" & Lr1) = sArr(i, 2)
            .Range("C" & Lr1) = sArr(i, 3)
            .Range("D" & Lr1) = sArr(i, 4)
            .Range("E" & Lr1) = sArr(i, 5)
            .Range("F" & Lr1) = sArr(i, 6)
            .Range("G" & Lr1) = sArr(i, 7)
            .Range("H" & Lr1) = sArr(i, 8)
        End If
    End With
    End If
    Next sh
Next i
Sheets("SL").Select
Application.ScreenUpdating = True
 
Dear Các Anh Chị, em muốn hỏi thêm 1 chút nữa, nếu khi tác sang các sheet mà em chỉ muốn lấy 1 số cột trong sheet SL thôi (do file gốc em có rất nhiều cột) Giả sử em chỉ muốn lấy sang sheet mới các cột A, B,D,F,H thì làm như thế nào ạ.
Em cảm ơn các anh chị.
 
d1207t đã viết:
Dear Các Anh Chị, em muốn hỏi thêm 1 chút nữa, nếu khi tác sang các sheet mà em chỉ muốn lấy 1 số cột trong sheet SL thôi (do file gốc em có rất nhiều cột) Giả sử em chỉ muốn lấy sang sheet mới các cột A, B,D,F,H thì làm như thế nào ạ.
Em cảm ơn các anh chị.
Nhấp chuột vào đây để mở rộng...
Bạn thay:
PHP: 
If .Name = sArr(i, 2) Then
            Lr1 = .Range("A10000").End(xlUp).Row + 1
            .Range("A" & Lr1) = sArr(i, 1)
            .Range("B" & Lr1) = sArr(i, 2)
            .Range("C" & Lr1) = sArr(i, 3)
            .Range("D" & Lr1) = sArr(i, 4)
            .Range("E" & Lr1) = sArr(i, 5)
            .Range("F" & Lr1) = sArr(i, 6)
            .Range("G" & Lr1) = sArr(i, 7)
            .Range("H" & Lr1) = sArr(i, 8)
        End If

thành:

PHP: 
If .Name = sArr(i, 2) Then
            Lr1 = .Range("A10000").End(xlUp).Row + 1
            .Range("A" & Lr1) = sArr(i, 1)
            .Range("B" & Lr1) = sArr(i, 2)
          '  .Range("C" & Lr1) = sArr(i, 3)
            .Range("D" & Lr1) = sArr(i, 4)
           ' .Range("E" & Lr1) = sArr(i, 5)
            .Range("F" & Lr1) = sArr(i, 6)
          '  .Range("G" & Lr1) = sArr(i, 7)
            .Range("H" & Lr1) = sArr(i, 8)
        End If
 
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

D
  • Đã giải quyết
Quản lý email outlook qua VBA cần giúp đỡ (2 người xem)
2
Trả lời
22
Đọc
424
nguyendang95
N
G
Xin Code xóa Module.
Trả lời
7
Đọc
202
VetMini
V
S
Mở 2 cửa sổ riêng biệt (1 người xem)
2
Trả lời
30
Đọc
23K
sakuraluu
S
F
Nhập dấu . (chấm) ở bàn phím phụ không tự chuyển thành dấu , (phẩy)
Trả lời
16
Đọc
57K
tubaodn21
tubaodn21
PhanTuHuong
Sách Lập trình VBA trong AutoCAD đã có mặt
    • Thích
    • Yêu thích
2
Trả lời
21
Đọc
1K
PhanTuHuong
PhanTuHuong
L
Lỗi font khi convert từ pdf
Trả lời
3
Đọc
133
lamvu0677
L
N
Khắc phục lỗi "The picture is too large and will be truncated"
Trả lời
9
Đọc
5K
SonBDND
S
GPE-Trợ Lý
[GPE] TALKSHOW: PHÂN TÍCH BÁO CÁO ĐỘ NHẠY SỬ DỤNG EXCEL SOLVER (1 người xem)
    • Thích
Trả lời
0
Đọc
849
GPE-Trợ Lý
GPE-Trợ Lý
K
  • Question Question
nhờ ace giúp đỡ tự động filter và In hàng loạt từng mục trong piviot table
Trả lời
1
Đọc
108
khkkh
K
K
Xin dax tính tỷ trọng doanh thu (1 người xem)
Trả lời
18
Đọc
781
SteveNguyen1991
S
F
  • Question Question
Tự động Merge Mail bằng VBA
Trả lời
6
Đọc
209
Hoàng Tuấn 868
H
N
Một ví dụ về XLL add-in: Tương tác với Google Gemini dưới dạng công thức bảng tính
    • Thích
Trả lời
0
Đọc
133
nguyendang95
N
H
Nhờ anh/chị giúp đỡ em viết công thức trừ dữ liệu theo FiFo (1 người xem)
Trả lời
1
Đọc
118
HieuCD
H
BNTT
LockXLS - Chương trình bảo vệ an toàn cho các file bảng tính Excel
    • Thích
4 5 6
Trả lời
118
Đọc
73K
YêuCN
Y
vsitcnh
Hỗ trợ công thức tính điểm dựa theo điều kiện.
Trả lời
14
Đọc
210
thuytrangbp28
T
micam111
  • Question Question
Cách chạy nhiều đồng hồ đếm giờ trong VBA
Trả lời
4
Đọc
704
thuytrangbp28
T
B
Xin giải pháp chống sửa, xóa dữ liệu đã nhập vào từ ngày hôm trước. (1 người xem)
    • Thích
2
Trả lời
26
Đọc
7K
Tuấn Bụng Bự
Tuấn Bụng Bự
Emyeuexcel
  • Question Question
In tất cả các file trong cùng 1 thư mục
Trả lời
3
Đọc
218
Hoàng Tuấn 868
H
1
Hỏi về đánh dấu hàng ngang hàng dọc bằng màu khi kích chuột vào 1 ô
Trả lời
7
Đọc
213
Gà Công Nghệ
Gà Công Nghệ
P
Excell code vba : Tìm Cell để sửa dữ liệu
    • Buồn
2
Trả lời
26
Đọc
592
Phạm Trường 80
P
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
TALK SHOW: CÙNG NHẢY LAM BA ĐA VỚI HÀM LAMBDA (λ) EXCEL 365
Back
Top Bottom