trích lọc dữ liệu ra file excel khác có điều kiện (2 người xem)

katylove83 · 30/12/14

xin chào các anh
em có bài này nhờ các anh xem giúp
em muốn trích lọc dữ liệu tại file nguồn"trích lọc ra nhìu file có định sẵn" ra nhiều file khác nhau với điều kiện là tại cột G tên file thì đã được tạo các mã sẵn,
tại cột G có bao nhiêu điều kiện thì em sẽ có bao nhiêu file excel đã được tạo sẵn tên file trùng với các mã tại cột G
ở bài này e ví dụ có 2 file excel vì gửi lên nhiều sợ nặng.

vậy nhờ các anh giúp em bai này nhé
cám ơn

katylove83 · 31/12/14

katylove83 đã viết:
xin chào các anh
em có bài này nhờ các anh xem giúp
em muốn trích lọc dữ liệu tại file nguồn"trích lọc ra nhìu file có định sẵn" ra nhiều file khác nhau với điều kiện là tại cột G tên file thì đã được tạo các mã sẵn,
tại cột G có bao nhiêu điều kiện thì em sẽ có bao nhiêu file excel đã được tạo sẵn tên file trùng với các mã tại cột G
ở bài này e ví dụ có 2 file excel vì gửi lên nhiều sợ nặng.

vậy nhờ các anh giúp em bai này nhé
cám ơn
có anh GPE nào giúp em với, hoặc nếu vba ko thể thực hiện được thì nhờ các anh trả lời gíup để em tìm hướng khác

xin cám ơn

nmhung49 · 31/12/14

Thử code này

[GPECODE=vb]

Sub GPE()
Dim rng As Range, endR As Long
With Application
.DisplayAlerts = False
.ScreenUpdating = False
With Sheets("sheet1")
endR = .Range("G65000").End(xlUp).Row
.Range("G2:G" & endR).Copy Range("J2")
.Range("J2:J" & endR).RemoveDuplicates 1, xlYes
.Range("A2").CurrentRegion.AutoFilter
For Each rng In .Range("J3:J" & .Range("J65000").End(xlUp).Row)
With .Range("A2").CurrentRegion
.AutoFilter 7, rng.Value
.Copy
End With
Workbooks.Add: ActiveSheet.Paste
With ActiveWorkbook
.SaveAs ThisWorkbook.Path & "\" & rng.Value, FileFormat:=xlOpenXMLWorkbook
.Close
End With
Next
.Range("A2").CurrentRegion.AutoFilter
End With
.ScreenUpdating = True
.DisplayAlerts = True
End With
End Sub
[/GPECODE]

Lê Duy Thương · 31/12/14

katylove83 đã viết:
xin chào các anh
em có bài này nhờ các anh xem giúp
em muốn trích lọc dữ liệu tại file nguồn"trích lọc ra nhìu file có định sẵn" ra nhiều file khác nhau với điều kiện là tại cột g tên file thì đã được tạo các mã sẵn,
tại cột g có bao nhiêu điều kiện thì em sẽ có bao nhiêu file excel đã được tạo sẵn tên file trùng với các mã tại cột g
ở bài này e ví dụ có 2 file excel vì gửi lên nhiều sợ nặng.

vậy nhờ các anh giúp em bai này nhé
cám ơn

CODE ĐÂY
Option Explicit

PHP:

Sub GPE1()
Dim I As Long, Sheets_name As String
On Error Resume Next
I = 3
Do
  Sheets_name = Sheets("MAIN").Cells(I, 7)
  Sheets(Sheets_name).Select
  If Err.Number > 0 Then
    ThisWorkbook.Worksheets.Add.Name = Sheets_name
    Err.Number = 0
  End If
  I = I + 1
Loop While Sheets("MAIN").Cells(I, 7) <> ""
End Sub

PHP:

Sub GPE2()
Application.ScreenUpdating = False
  Dim Sh As Worksheet
  For Each Sh In Worksheets
   If Sh.Name <> "MAIN" Then
   Sh.Range("A1:h1000").Clear
    With Range(Sheets("MAIN").[A2], Sheets("MAIN").[h65536].End(xlUp))
    .AutoFilter 7, Sh.Name
    .Copy: Sh.[A2].PasteSpecial
    .AutoFilter
    End With
  End If
  Next
Application.ScreenUpdating = True
End Sub

PHP:

Sub GPE3()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim Sh As Worksheet
For Each Sh In Worksheets
   If Sh.Name <> "MAIN" Then
    Sh.Copy
    ActiveWorkbook.SaveAs ThisWorkbook.Path & "\" & Sh.Name, 51
    ActiveWorkbook.Close
  End If
Next
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub

PHP:

Sub GPE4()
 Dim Sh As Worksheet, Delsh As Worksheet
  Application.DisplayAlerts = False
  On Error Resume Next
    Set Sh = Sheets("main")
  For Each Delsh In ThisWorkbook.Worksheets
    If Delsh.Name <> Sh.Name Then Delsh.Delete
     Next
End Sub

thử xem file nhé
hy vọng trúng

katylove83 · 2/1/15

Lê Duy Thương đã viết:

CODE ĐÂY
Option Explicit

PHP:

Sub GPE1()
Dim I As Long, Sheets_name As String
On Error Resume Next
I = 3
Do
  Sheets_name = Sheets("MAIN").Cells(I, 7)
  Sheets(Sheets_name).Select
  If Err.Number > 0 Then
    ThisWorkbook.Worksheets.Add.Name = Sheets_name
    Err.Number = 0
  End If
  I = I + 1
Loop While Sheets("MAIN").Cells(I, 7) <> ""
End Sub

PHP:

Sub GPE2()
Application.ScreenUpdating = False
  Dim Sh As Worksheet
  For Each Sh In Worksheets
   If Sh.Name <> "MAIN" Then
   Sh.Range("A1:h1000").Clear
    With Range(Sheets("MAIN").[A2], Sheets("MAIN").[h65536].End(xlUp))
    .AutoFilter 7, Sh.Name
    .Copy: Sh.[A2].PasteSpecial
    .AutoFilter
    End With
  End If
  Next
Application.ScreenUpdating = True
End Sub

PHP:

Sub GPE3()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim Sh As Worksheet
For Each Sh In Worksheets
   If Sh.Name <> "MAIN" Then
    Sh.Copy
    ActiveWorkbook.SaveAs ThisWorkbook.Path & "\" & Sh.Name, 51
    ActiveWorkbook.Close
  End If
Next
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub

PHP:

Sub GPE4()
 Dim Sh As Worksheet, Delsh As Worksheet
  Application.DisplayAlerts = False
  On Error Resume Next
    Set Sh = Sheets("main")
  For Each Delsh In ThisWorkbook.Worksheets
    If Delsh.Name <> Sh.Name Then Delsh.Delete
     Next
End Sub

thử xem file nhé
hy vọng trúng

anh ơi code của anh sao e clik nút mà nó ko thấy gì cả ta

katylove83 · 2/1/15

nmhung49 đã viết:
Thử code này

[GPECODE=vb]

Sub GPE()
Dim rng As Range, endR As Long
With Application
.DisplayAlerts = False
.ScreenUpdating = False
With Sheets("sheet1")
endR = .Range("G65000").End(xlUp).Row
.Range("G2:G" & endR).Copy Range("J2")
.Range("J2:J" & endR).RemoveDuplicates 1, xlYes
.Range("A2").CurrentRegion.AutoFilter
For Each rng In .Range("J3:J" & .Range("J65000").End(xlUp).Row)
With .Range("A2").CurrentRegion
.AutoFilter 7, rng.Value
.Copy
End With
Workbooks.Add: ActiveSheet.Paste
With ActiveWorkbook
.SaveAs ThisWorkbook.Path & "\" & rng.Value, FileFormat:=xlOpenXMLWorkbook
.Close
End With
Next
.Range("A2").CurrentRegion.AutoFilter
End With
.ScreenUpdating = True
.DisplayAlerts = True
End With
End Sub
[/GPECODE]

anh ơi code của anh chạy thì tháy ok lắm, cám ơn anh nhé

Quang_Hải · 2/1/15

katylove83 đã viết:
anh ơi code của anh chạy thì tháy ok lắm, cám ơn anh nhé

Sao kỳ vậy ta? Code và yêu cầu ban đầu chẳng ăn gì với nhau mà chạy thì thấy OK lắm lắm

katylove83 · 3/1/15

quanghai1969 đã viết:
Sao kỳ vậy ta? Code và yêu cầu ban đầu chẳng ăn gì với nhau mà chạy thì thấy OK lắm lắm

hic hic
yêu cầu là muốn trích lọc ra nhiều file excel khác nhau theo điều kiện tại cột G cột G có các mã 2002,3001... thì sẽ cho ra mỗi file excel tương ứng với các mã này và trong file ẽcel này thì có các dữ liệu tương ứng với mã này.
em thấy chạy code của a hùng nó ra mà kết quả như đúng .
tuy nhiên sau khi kiểm tra lại thì có trường hợp này thì chưa đúng
ví dụ: sau khi đã cho ra các file excel tương ứng rồi bây giờ tại file nguồn ta xóa hết và chỉ để lại 1 mã bất kỳ lúc ta chạy code thì mã này cho ra
file excel của mã này thôi. e muốn update vào file excel của mã này tiếp theo luôn được không vậy ?
có nghĩa là dữ liệu sẽ được cho vào các file excel là liên tục chứ ko phải chỉ là dữ liệu hiên tại của file nguồn.

Quang_Hải · 3/1/15

katylove83 đã viết:
hic hic
yêu cầu là muốn trích lọc ra nhiều file excel khác nhau theo điều kiện tại cột G cột G có các mã 2002,3001... thì sẽ cho ra mỗi file excel tương ứng với các mã này và trong file ẽcel này thì có các dữ liệu tương ứng với mã này.
em thấy chạy code của a hùng nó ra mà kết quả như đúng .
tuy nhiên sau khi kiểm tra lại thì có trường hợp này thì chưa đúng
ví dụ: sau khi đã cho ra các file excel tương ứng rồi bây giờ tại file nguồn ta xóa hết và chỉ để lại 1 mã bất kỳ lúc ta chạy code thì mã này cho ra
file excel của mã này thôi. e muốn update vào file excel của mã này tiếp theo luôn được không vậy ?
có nghĩa là dữ liệu sẽ được cho vào các file excel là liên tục chứ ko phải chỉ là dữ liệu hiên tại của file nguồn.

Thử đám rừng này coi sao

PHP:

Sub GetData()
Dim arr(), Res(), Tem(), Dic As Object
Dim i&, j&, k&, TieuDe(), Item, FileName$
TieuDe = [A2:H2].Value
arr = Range("A3", [H65536].End(3)).Value
Set Dic = CreateObject("scripting.dictionary")
For i = 1 To UBound(arr)
   Dic(arr(i, 7)) = ""
Next
For Each Item In Dic.keys
   ReDim Tem(1 To UBound(arr), 1 To 8)
   k = 0
   For i = 1 To UBound(arr)
      If arr(i, 7) = Item Then
         k = k + 1
         Tem(k, 1) = k
         For j = 2 To 8
            Tem(k, j) = arr(i, j)
         Next
      End If
   Next
   FileName = ThisWorkbook.Path & "\" & Item & ".xlsx"
   If k Then
      With CreateObject("scripting.FileSystemObject")
         If .FileExists(FileName) Then
            With Workbooks.Open(FileName)
               With .Sheets(CStr(Item))
                  .[A65536].End(3)(2).Resize(k, 8) = Tem
                  .Range("A3", .[A65536].End(3)) = [row(a:a)]
               End With
               .Close True
            End With
         Else
            With Workbooks.Add
               .ActiveSheet.Name = Item
               .ActiveSheet.[A65536].End(3)(2).Resize(, 8) = TieuDe
               .ActiveSheet.[A65536].End(3)(2).Resize(k, 8) = Tem
               .SaveAs FileName
               .Close
            End With
         End If
      End With
   End If
Next
End Sub

Lê Duy Thương · 3/1/15

katylove83 đã viết:
anh ơi code của anh sao e clik nút mà nó ko thấy gì cả ta

bạn đã giải nén ra chưa. chắc để luôn file zar chạy rồi.

katylove83 · 4/1/15

quanghai1969 đã viết:

Thử đám rừng này coi sao

PHP:

Sub GetData()
Dim arr(), Res(), Tem(), Dic As Object
Dim i&, j&, k&, TieuDe(), Item, FileName$
TieuDe = [A2:H2].Value
arr = Range("A3", [H65536].End(3)).Value
Set Dic = CreateObject("scripting.dictionary")
For i = 1 To UBound(arr)
   Dic(arr(i, 7)) = ""
Next
For Each Item In Dic.keys
   ReDim Tem(1 To UBound(arr), 1 To 8)
   k = 0
   For i = 1 To UBound(arr)
      If arr(i, 7) = Item Then
         k = k + 1
         Tem(k, 1) = k
         For j = 2 To 8
            Tem(k, j) = arr(i, j)
         Next
      End If
   Next
   FileName = ThisWorkbook.Path & "\" & Item & ".xlsx"
   If k Then
      With CreateObject("scripting.FileSystemObject")
         If .FileExists(FileName) Then
            With Workbooks.Open(FileName)
               With .Sheets(CStr(Item))
                  .[A65536].End(3)(2).Resize(k, 8) = Tem
                  .Range("A3", .[A65536].End(3)) = [row(a:a)]
               End With
               .Close True
            End With
         Else
            With Workbooks.Add
               .ActiveSheet.Name = Item
               .ActiveSheet.[A65536].End(3)(2).Resize(, 8) = TieuDe
               .ActiveSheet.[A65536].End(3)(2).Resize(k, 8) = Tem
               .SaveAs FileName
               .Close
            End With
         End If
      End With
   End If
Next
End Sub

chuẩn anh hải à, cám ơn anh nhiù nhé

katylove83 · 4/1/15

Lê Duy Thương đã viết:
bạn đã giải nén ra chưa. chắc để luôn file zar chạy rồi.

dạ em giải nén rồi, nhưng ko thấy động tĩnh gì hết anh ah, có thể thiếu gì đó chăng.

trích lọc dữ liệu ra file excel khác có điều kiện (2 người xem)

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

katylove83

Thành viên hoạt động

File đính kèm

katylove83

Thành viên hoạt động

nmhung49

Thành viên tích cực

Lê Duy Thương

Cạo lấy gì gội (Dịch quá không gội được)

File đính kèm

katylove83

Thành viên hoạt động

katylove83

Thành viên hoạt động

Quang_Hải

Thành viên gạo cội

katylove83

Thành viên hoạt động

Quang_Hải

Thành viên gạo cội

Lê Duy Thương

Cạo lấy gì gội (Dịch quá không gội được)

katylove83

Thành viên hoạt động

katylove83

Thành viên hoạt động

Bài viết mới nhất

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

Thời gian đếm ngược.