[Help] VBA Coppy giá trị có điều kiện sang File mới (1 người xem)

robinhsoon · 1/9/17

Thân Chào cả Nhà GPE...!
Em có vấn đề này nhờ các Thầy giúp với ạ.
Hiện tại em có 01 list data, tại đây em làm việc trên 03 cột M, N và O (%GAP, So Sanh, Gia Khuyen Mai)
Công việc của em là:
- Tại cột % GAP (M): em lấy những giá trị -15%< và >15% coppy các dòng sang File mới (tạm thời là File Check) đặt tại Sheets Check Gia Trung Binh..
- Tương tự Tại cột So Sanh (N): em lấy những giá trị -15%< và >15% coppy các dòng sang File Check (File vừa mới tạo) đặt tại Sheets Check Gia So Sanh..
- Và tại cột Gia Khuyen Mai (O): em cũng lấy những giá trị -15%< và >15% coppy các dòng sang File Check (File vừa mới tạo) đặt tại Sheets Check Gia Khuyen Mai..

Mong các Thầy giúp đỡ..! Em chân thành cảm ơn ạ!

dhn46 · 1/9/17

Bạn tìm hiểu Advanced filter mà áp dụng.

Cái này dùng công cụ có sẵn vừa nhanh lại không phải Code, nếu có muốn Code thì ghi lai Macro cũng giải quyết được vấn đề.

robinhsoon · 1/9/17

dhn46 đã viết:
Bạn tìm hiểu Advanced filter mà áp dụng.

Cái này dùng công cụ có sẵn vừa nhanh lại không phải Code, nếu có muốn Code thì ghi lai Macro cũng giải quyết được vấn đề.

dạ! em có dùng cách ghi lại Macro rồi ạ.. nhưng lúc chạy thì nó lại bị lỗi và code lại dài quá...
Mong Thầy giúp đỡ ạ

dhn46 · 1/9/17

Bạn đưa file bạn làm lên đây để mọi người xem, mà tôi cũng không phải là Thầy gì đâu bạn, tôi là DHN46 nhé.

VetMini · 1/9/17

robinhsoon đã viết:
dạ! em có dùng cách ghi lại Macro rồi ạ.. nhưng lúc chạy thì nó lại bị lỗi và code lại dài quá...
Mong Thầy giúp đỡ ạ

Tập làm tự mình cho quen.
Code dài quá thì có ảnh hưởng gì đến công việc?
Lỗi thì đưa code lên và cho biết nó báo lỗi chỗ nào.

robinhsoon · 1/9/17

VetMini đã viết:
Tập làm tự mình cho quen.
Code dài quá thì có ảnh hưởng gì đến công việc?
Lỗi thì đưa code lên và cho biết nó báo lỗi chỗ nào.

em làm nhưng đó bị lỗi mong Anh/Chị giúp đỡ

dhn46 · 1/9/17

Gợi ý bạn làm nhé:

Bước 1: Tạo 1 sheet mới - trong đó có các điều kiện Advanced filter (cái này bạn tìm hiểu trên diễn đàn nhé)
Bước 2: ghi Macro với nội dung sau
- Tại sheet mới tạo chọn Data|Advanced Filter
- Điền các field vào ô điều kiện Advanced Filter, vùng đích là Sheet vừa tạo => OK
- Khi sheet mới có kết quả => phải chuột vào tab sheet mới => Move and Copy => Save file mới.

Trước tiên bạn tìm hiểu Advanced trên diễn đàn nhé.

CarotNho · 1/9/17

robinhsoon đã viết:
Thân Chào cả Nhà GPE...!
Em có vấn đề này nhờ các Thầy giúp với ạ.
Hiện tại em có 01 list data, tại đây em làm việc trên 03 cột M, N và O (%GAP, So Sanh, Gia Khuyen Mai)
Công việc của em là:
- Tại cột % GAP (M): em lấy những giá trị -15%< và >15% coppy các dòng sang File mới (tạm thời là File Check) đặt tại Sheets Check Gia Trung Binh..
- Tương tự Tại cột So Sanh (N): em lấy những giá trị -15%< và >15% coppy các dòng sang File Check (File vừa mới tạo) đặt tại Sheets Check Gia So Sanh..
- Và tại cột Gia Khuyen Mai (O): em cũng lấy những giá trị -15%< và >15% coppy các dòng sang File Check (File vừa mới tạo) đặt tại Sheets Check Gia Khuyen Mai..

Mong các Thầy giúp đỡ..! Em chân thành cảm ơn ạ!

Bạn iêu xem trong file đính kèm nghen
Chỗ điều kiện -15%< và >15% bạn điều chỉnh lại nghen, viết vậy hem có đúng

robinhsoon · 1/9/17

CarotNho đã viết:
Bạn iêu xem trong file đính kèm nghen
Chỗ điều kiện -15%< và >15% bạn điều chỉnh lại nghen, viết vậy hem có đúng

Dạ! Em cảm ơn Chị đã giúp em ạ.. Code nhanh và hay lắm ạ... Nhưng nó không coppy được Hàng A1 với màu của giá trị đó ạ..!

robinhsoon · 1/9/17

dhn46 đã viết:
Gợi ý bạn làm nhé:

Bước 1: Tạo 1 sheet mới - trong đó có các điều kiện Advanced filter (cái này bạn tìm hiểu trên diễn đàn nhé)
Bước 2: ghi Macro với nội dung sau
- Tại sheet mới tạo chọn Data|Advanced Filter
- Điền các field vào ô điều kiện Advanced Filter, vùng đích là Sheet vừa tạo => OK
- Khi sheet mới có kết quả => phải chuột vào tab sheet mới => Move and Copy => Save file mới.

Trước tiên bạn tìm hiểu Advanced trên diễn đàn nhé.

Chào anh DHN46! em đã tự làm tới bước này rồi ạ.. Nhưng đang bí không biết phải làm sao, mong anh giúp đỡ...
Em chạy tới bước Move and coppy các Sheet ra rồi nhưng không biết làm cách nào để Save File mới trên đường dẫn của File hiện hạnh ạ...
Mong anh giúp đỡ

robinhsoon · 1/9/17

hpkhuong đã viết:
Tóm lại. Tạo ra 3 File (mỗi file là 1 sheet như trên) hay là tạo 1 File gồm 3 sheet như trên???

Dạ! 01 File gồm 03 Sheet ạ.!

dhn46 · 1/9/17

robinhsoon đã viết:
Chào anh DHN46! em đã tự làm tới bước này rồi ạ.. Nhưng đang bí không biết phải làm sao, mong anh giúp đỡ...
Em chạy tới bước Move and coppy các Sheet ra rồi nhưng không biết làm cách nào để Save File mới trên đường dẫn của File hiện hạnh ạ...
Mong anh giúp đỡ

Bạn đã làm chuẩn các bước, giờ bạn record macro như sau nhé:

Bước 1: chạy Macro bạn vừa tạo.

Bước 2: tại workbook Report.xlsm bạn bấm record macro => chọn workbook vừa mới tạo => Save theo đường dẫn tùy ý bạn => Kết thúc Macro

Bước 3: Bạn copy toàn bộ nội dung Macro save workbook (bỏ dòng đầu tiên và cuối cùng - Sub Macro2() ...End Sub) rồi Paste vào cuối Macro tạo report bạn đã làm trước đó (Copy trên End Sub nhé)

=> Bây giờ bạn chạy thử xem có đúng ý chưa.

robinhsoon · 1/9/17

dhn46 đã viết:
Bạn đã làm chuẩn các bước, giờ bạn record macro như sau nhé:

Bước 1: chạy Macro bạn vừa tạo.

Bước 2: tại workbook Report.xlsm bạn bấm record macro => chọn workbook vừa mới tạo => Save theo đường dẫn tùy ý bạn => Kết thúc Macro

Bước 3: Bạn copy toàn bộ nội dung Macro save workbook (bỏ dòng đầu tiên và cuối cùng - Sub Macro2() ...End Sub) rồi Paste vào cuối Macro tạo report bạn đã làm trước đó (Copy trên End Sub nhé)

=> Bây giờ bạn chạy thử xem có đúng ý chưa.

Bước 3 thì em biết rồi ạ..! Nhưng cái em muốn là Save Workbook ở vị trí của File Macro... Khi di chuyển ở bất kỳ đường dẫn nào thì khi chạy và save File thì nó sẽ đi chung với File Macro luôn.. chứ em không muốn nó save ở một đường dẫn cố định...

Lê Duy Thương · 1/9/17

robinhsoon đã viết:
Bước 3 thì em biết rồi ạ..! Nhưng cái em muốn là Save Workbook ở vị trí của File Macro... Khi di chuyển ở bất kỳ đường dẫn nào thì khi chạy và save File thì nó sẽ đi chung với File Macro luôn.. chứ em không muốn nó save ở một đường dẫn cố định...

bạn thêm 4 câu này vào cuối của sub thử xem

Mã:

Application.DisplayAlerts = False
   ActiveWorkbook.SaveAs ThisWorkbook.Path & "\" & "save Date_" & Date, 51
   ActiveWorkbook.Close
 Application.DisplayAlerts = True

cái "save Date_" & Date" có thể thay tùy ý

dhn46 · 3/9/17

robinhsoon đã viết:
Chào anh DHN46! em đã tự làm tới bước này rồi ạ.. Nhưng đang bí không biết phải làm sao, mong anh giúp đỡ...
Em chạy tới bước Move and coppy các Sheet ra rồi nhưng không biết làm cách nào để Save File mới trên đường dẫn của File hiện hạnh ạ...
Mong anh giúp đỡ

Đến bài #10 là bạn đã có thể tự mình record macro để ứng dụng vào mục đích của mình. Giờ tôi sẽ hướng dẫn tiếp bạn những thắc mắc tại bài #10

- Thường ghi macro save sẽ cho ra đoạn code như sau

Mã:

    ActiveWorkbook.SaveAs Filename:="C:\Users\DHN46\Desktop\Book1.xlsm", _
        FileFormat:=xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False

Bạn để ý đoạn

Mã:

"C:\Users\DHN46\Desktop\Book1.xlsm"

có đặc điểm: là đường dẫn lưu, là dạng chuỗi => Như vậy làm cách nào để thay đổi đoạn này thành 1 chuỗi là đường dẫn mong muốn thì bạn sẽ đạt yêu cầu.

Yêu cầu Save vào thư mục cùng file gốc.

Để xác định thư mục hiện tại của file chứa macro ta có lệnh

Mã:

ThisWorkbook.Path
Tức là trả về
C:\Users\DHN46\Desktop

thêm tên file muốn save nữa thì sẽ là

Mã:

ThisWorkbook.Path & "\" & "Book1.xlsm"

Bạn thay vào code save đã record thì sẽ cho ra kết quả mong muốn.

Tóm lại: Căn bản bạn cần record macro chính xác sau đó tìm từ khóa để giữ lại những dòng đúng, loại bỏ dòng thừa, cuối cùng tìm hiểu thêm những câu lệnh mà không ghi được. Bạn cũng đừng vội vàng mà rút gọn câu lệnh khi chưa hiểu gì, dài 1 chút nhưng cho bạn biết nó sẽ làm gì thì thuận tiện cho bạn tới lúc thành thạo

minhtungph · 3/9/17

Bạn Copy Code bên dưới vào một module nhé, code này mình nghĩ còn có thế tối ưu hơn nữa là dùng vòng lặp để duyệt lỡ yêu cầu có 10 yêu cầu thì sao, có cao thủ nào giúp được khoản duyệt Array không ạ.
PMT.

Mã:

Function FilterData(rngFilter As Range, ColFilter As Integer, minVal As Single, maxVal As Single)
    Dim sArr As Variant, i As Long, Temp As Variant, k As Long, j As Long
    Dim x As Long, y As Long
    On Error Resume Next
    sArr = rngFilter.Value: ReDim Temp(1 To UBound(sArr), 1 To UBound(sArr, 2))
    For i = 1 To UBound(sArr)
        If sArr(i, ColFilter) > minVal And sArr(i, ColFilter) < maxVal Then
            k = k + 1
            For j = 1 To UBound(sArr, 2)
                Temp(k, j) = sArr(i, j)
            Next j
        End If
    Next i
    ReDim sArr(1 To k, 1 To 16)
    For x = 1 To k
        For y = 1 To 16
            sArr(x, y) = Temp(x, y)
        Next y
    Next x
    FilterData = sArr
End Function
Sub Export()
    Dim temp1 As Variant, temp2 As Variant, temp3 As Variant, tieude As Range
    Application.ScreenUpdating = False
    On Error GoTo Thoat
    temp1 = FilterData(Sheet1.Range("data"), 12, -15 / 100, 15 / 100)
    temp2 = FilterData(Sheet1.Range("data"), 13, -15 / 100, 15 / 100)
    temp3 = FilterData(Sheet1.Range("data"), 14, -15 / 100, 15 / 100)
    Set tieude = Sheet1.Range("tieude")
    With Workbooks.Add
        .Worksheets.Add , ActiveSheet, 3 - .Worksheets.Count
        If IsArray(temp1) Then
            With .Worksheets(1)
                .Name = "Check Gia Trung Binh"
                tieude.Copy .Range("A1")
                .Range("A3").Resize(UBound(temp1), 16).Value = temp1
            End With
        End If
        
        If IsArray(temp2) Then
            With .Worksheets(2)
                .Name = "Check Gia So Sanh"
                tieude.Copy .Range("A1")
                .Range("A3").Resize(UBound(temp2), 16).Value = temp2
            End With
        End If
        
        If IsArray(temp3) Then
            With .Worksheets(3)
                .Name = "Check Gia Khuyen Mai"
                tieude.Copy .Range("A1")
                .Range("A3").Resize(UBound(temp3), 16).Value = temp3
            End With
        End If
        .SaveAs ThisWorkbook.Path & "\" & "Export" & Hour(Time) & Minute(Time) & Second(Time) & ".xlsx"
        .Close
    End With
Thoat:
    Application.ScreenUpdating = True
End Sub

minhtungph · 3/9/17

Ngắn hơn tí

Mã:

Function FilterData(rngFilter As Range, ColFilter As Integer, minVal As Single, maxVal As Single)
    Dim sArr As Variant, i As Long, Temp As Variant, k As Long, j As Long
    Dim x As Long, y As Long
    On Error Resume Next
    sArr = rngFilter.Value: ReDim Temp(1 To UBound(sArr), 1 To UBound(sArr, 2))
    For i = 1 To UBound(sArr)
        If sArr(i, ColFilter) > minVal And sArr(i, ColFilter) < maxVal Then
            k = k + 1
            For j = 1 To UBound(sArr, 2)
                Temp(k, j) = sArr(i, j)
            Next j
        End If
    Next i
    ReDim sArr(1 To k, 1 To 16)
    For x = 1 To k
        For y = 1 To 16
            sArr(x, y) = Temp(x, y)
        Next y
    Next x
    FilterData = sArr
End Function
Sub Export()
    Dim temp1 As Variant, temp2 As Variant, temp3 As Variant, tieude As Range
    Dim LArr As Variant, vArr As Variant, v As Byte
    Application.ScreenUpdating = False
    On Error GoTo Thoat
    temp1 = FilterData(Sheet1.Range("data"), 12, -15 / 100, 15 / 100)
    temp2 = FilterData(Sheet1.Range("data"), 13, -15 / 100, 15 / 100)
    temp3 = FilterData(Sheet1.Range("data"), 14, -15 / 100, 15 / 100)
    LArr = Array(temp1, temp2, temp3)
    Set tieude = Sheet1.Range("tieude")
    Application.SheetsInNewWorkbook = 3
    With Workbooks.Add
        v = 1
        .Worksheets(1).Name = "Check Gia Trung Binh"
        .Worksheets(2).Name = "Check Gia So Sanh"
        .Worksheets(3).Name = "Check Gia Khuyen Mai"
        For Each vArr In LArr
            If IsArray(vArr) Then
                With .Worksheets(v)
                    tieude.Copy .Range("A1")
                    .Range("A3").Resize(UBound(vArr), 16).Value = vArr
                End With
                v = v + 1
            End If
        Next vArr
        .SaveAs ThisWorkbook.Path & "\" & "Export" & Hour(Time) & Minute(Time) & Second(Time) & ".xlsx"
        .Close
    End With
Thoat:
    Application.ScreenUpdating = True
End Sub

minhtungph · 3/9/17

Code ở trên mình bị nhằm cột, cột 13,14,15 mà nhằm 12,13,14 , up code khác, tuy nhiên vẫn chậm hơn code của bạn Hiền , test ra kết quả khác nhau, mình test với 70.000 dòng trong 15 giây, cũng chưa biết đúng hay sai

Mã:

Sub Export()
    Dim sArr As Variant
    Dim temp1 As Variant, temp2 As Variant, temp3 As Variant, kq1 As Variant, kq2 As Variant, kq3 As Variant
    Dim tieude As Range
    Dim LArr As Variant, temp As Variant, vArr As Variant, v As Byte, t As Single
    Dim i As Long, j As Long, c As Long, maxVal As Long, k1 As Long, k2 As Long, k3 As Long
    t = Timer
    Application.ScreenUpdating = False
    sArr = Sheet1.Range("data").Value: temp = Sheet1.Range("data")(, 13).Resize(UBound(sArr), 3)
    ReDim temp1(1 To UBound(sArr))
    ReDim temp2(1 To UBound(sArr))
    ReDim temp3(1 To UBound(sArr))
    
    On Error Resume Next
    For i = 1 To UBound(temp)
        If temp(i, 1) > -15 / 100 And temp(i, 1) < 15 / 100 Then
            k1 = k1 + 1
            temp1(k1) = i
        End If
        If temp(i, 2) > -15 / 100 And temp(i, 2) < 15 / 100 Then
            k2 = k2 + 1
            temp2(k2) = i
        End If
        If temp(i, 3) > -15 / 100 And temp(i, 3) < 15 / 100 Then
            k3 = k3 + 1
            temp3(k3) = i
        End If
    Next i
    
    On Error GoTo 0
    
    If k1 Then ReDim kq1(1 To k1, 1 To 17)
    If k2 Then ReDim kq2(1 To k2, 1 To 17)
    If k3 Then ReDim kq3(1 To k3, 1 To 17)
    
    
    v = 1: maxVal = WorksheetFunction.Max(k1, k2, k3)
    If maxVal = 0 Then GoTo Thoat
    On Error Resume Next
    For j = 1 To maxVal
        For c = 1 To 17
            kq1(j, c) = sArr(temp1(j), c)
            kq2(j, c) = sArr(temp2(j), c)
            kq3(j, c) = sArr(temp3(j), c)
        Next c
    Next j
    Erase sArr, temp1, temp2, temp3, temp
    On Error GoTo 0
    Set tieude = Sheet1.Range("tieude")
    Application.SheetsInNewWorkbook = 3

    With Workbooks.Add
        .Worksheets(1).Name = "Check Gia Trung Binh"
        .Worksheets(2).Name = "Check Gia So Sanh"
        .Worksheets(3).Name = "Check Gia Khuyen Mai"
        LArr = Array(kq1, kq2, kq3)
        For Each vArr In LArr
            If IsArray(vArr) Then
                With .Worksheets(v)
                    tieude.Copy .Range("A1")
                    .Range("A3").Resize(UBound(vArr), 17).Value = vArr
                End With
                v = v + 1
            End If
        Next vArr
        Set tieude = Nothing
        Erase LArr
        .SaveAs ThisWorkbook.Path & "\" & "Export" & Hour(Time) & Minute(Time) & Second(Time) & ".xlsx"
        .Close
    End With
Thoat:
    Application.ScreenUpdating = True
    MsgBox Timer - t
End Sub

[Help] VBA Coppy giá trị có điều kiện sang File mới (1 người xem)

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

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

File đính kèm

Hướng tới tương lai

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

Hướng tới tương lai

Ăn cùng góc phố

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

File đính kèm

Hướng tới tương lai

Thành viên chính thức

File đính kèm

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

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

File đính kèm

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

Hướng tới tương lai

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

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

Hướng tới tương lai

None

File đính kèm

None

File đính kèm

None

Đếm ngược thời gian