Tách 1 file thành nhiều files theo điều kiện

[suikt]

Chào các chuyên gia,

Mình có file quản lý quản lý thời gian làm việc như đính kèm.
Hàng tháng, mình phải tách files để gửi cho từng bộ phận (6 bộ phận) và từng trung tâm (77 trung tâm).
Mình nhờ chuyên gia cho em codes để em tách files theo loại được đặt sẵn ở cột A
Nếu là 1 thì tách theo cột G - Phòng ban thôi -- File mới lưu theo tên của phòng được tách;
Nếu là 2 thì tách theo cột G (Phòng ban) và cột F (Trung tâm TT) nữa -- file mới lưu theo tên phòng rồi đến TT được tách (ví dụ: Sale - TT01)

Mình cảm ơn rất nhiều.

 

[snow25]

Chào các chuyên gia,

Mình có file quản lý quản lý thời gian làm việc như đính kèm.
Hàng tháng, mình phải tách files để gửi cho từng bộ phận (6 bộ phận) và từng trung tâm (77 trung tâm).
Mình nhờ chuyên gia cho em codes để em tách files theo loại được đặt sẵn ở cột A
Nếu là 1 thì tách theo cột G - Phòng ban thôi -- File mới lưu theo tên của phòng được tách;
Nếu là 2 thì tách theo cột G (Phòng ban) và cột F (Trung tâm TT) nữa -- file mới lưu theo tên phòng rồi đến TT được tách (ví dụ: Sale - TT01)

Mình cảm ơn rất nhiều.

Không phải chuyên gia có được làm không.

 

[snow25]

Chào các chuyên gia,

Mình có file quản lý quản lý thời gian làm việc như đính kèm.
Hàng tháng, mình phải tách files để gửi cho từng bộ phận (6 bộ phận) và từng trung tâm (77 trung tâm).
Mình nhờ chuyên gia cho em codes để em tách files theo loại được đặt sẵn ở cột A
Nếu là 1 thì tách theo cột G - Phòng ban thôi -- File mới lưu theo tên của phòng được tách;
Nếu là 2 thì tách theo cột G (Phòng ban) và cột F (Trung tâm TT) nữa -- file mới lưu theo tên phòng rồi đến TT được tách (ví dụ: Sale - TT01)

Mình cảm ơn rất nhiều.

Code của gà đây nhé bạn.

Sub tachfile()
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Dim a As Long, lr As Long, i As Long, j As Long, arr, arr1, dic As Object, dk As String, arr2, dks As String, wb As Workbook, tieude As Range, k As Long
    Set dic = CreateObject("scripting.dictionary")
    With Sheets("Timesheet")
         lr = .Range("a" & Rows.Count).End(xlUp).Row
         If lr < 10 Then Exit Sub
         arr = .Range("A10:BA" & lr).Value
        Set tieude = .Range("A5:Ba8")
    End With
         For i = 1 To UBound(arr, 1)
             If arr(i, 1) = 1 Then
                dk = arr(i, 7)
             Else
                dk = arr(i, 7) & "-" & arr(i, 6)
             End If
             If Not dic.exists(dk) Then
                dic.Add dk, "KK"
             End If
        Next i
        arr2 = dic.keys
        For k = LBound(arr2) To UBound(arr2)
            dk = arr2(k)
            ReDim arr1(1 To UBound(arr, 1), 1 To UBound(arr, 2))
            a = 0
            For i = 1 To UBound(arr, 1)
                If arr(i, 1) = 1 Then
                    dks = arr(i, 7)
                Else
                    dks = arr(i, 7) & "-" & arr(i, 6)
                End If
            If dk = dks Then
               a = a + 1
               For j = 1 To UBound(arr, 2)
                   arr1(a, j) = arr(i, j)
               Next j
            End If
            Next i
          With Workbooks.Add
              .ActiveSheet.[A10].Resize(a, UBound(arr1, 2)) = arr1
              tieude.Copy .ActiveSheet.[A9]
             .SaveAs ThisWorkbook.Path & "\" & dk & ".xlsx"
             .Close
           End With
        Next k
      Application.ScreenUpdating = True
      Application.DisplayAlerts = True
End Sub

 

[suikt]

Không phải chuyên gia có được làm không.

Code của gà đây nhé bạn.

Sub tachfile()
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Dim a As Long, lr As Long, i As Long, j As Long, arr, arr1, dic As Object, dk As String, arr2, dks As String, wb As Workbook, tieude As Range, k As Long
    Set dic = CreateObject("scripting.dictionary")
    With Sheets("Timesheet")
         lr = .Range("a" & Rows.Count).End(xlUp).Row
         If lr < 10 Then Exit Sub
         arr = .Range("A10:BA" & lr).Value
        Set tieude = .Range("A5:Ba8")
    End With
         For i = 1 To UBound(arr, 1)
             If arr(i, 1) = 1 Then
                dk = arr(i, 7)
             Else
                dk = arr(i, 7) & "-" & arr(i, 6)
             End If
             If Not dic.exists(dk) Then
                dic.Add dk, "KK"
             End If
        Next i
        arr2 = dic.keys
        For k = LBound(arr2) To UBound(arr2)
            dk = arr2(k)
            ReDim arr1(1 To UBound(arr, 1), 1 To UBound(arr, 2))
            a = 0
            For i = 1 To UBound(arr, 1)
                If arr(i, 1) = 1 Then
                    dks = arr(i, 7)
                Else
                    dks = arr(i, 7) & "-" & arr(i, 6)
                End If
            If dk = dks Then
               a = a + 1
               For j = 1 To UBound(arr, 2)
                   arr1(a, j) = arr(i, j)
               Next j
            End If
            Next i
          With Workbooks.Add
              .ActiveSheet.[A10].Resize(a, UBound(arr1, 2)) = arr1
              tieude.Copy .ActiveSheet.[A9]
             .SaveAs ThisWorkbook.Path & "\" & dk & ".xlsx"
             .Close
           End With
        Next k
      Application.ScreenUpdating = True
      Application.DisplayAlerts = True
End Sub

Cảm ơn rất nhiều, và nhiều lắm luôn. Mình chạy ra files được rồi.

Có thể "đòi hỏi giúp thêm chút" nữa ko? Hehe
- Mình muốn toàn bộ dữ liệu từ hàng số 9 trở lên là được giữ nguyên - tức là có tựa đề
- Format vẫn giữ nguyên được ko? Tức có kẽ ngang, kẽ dọc í;
- Và cuối cùng là Mỗi file tách ra có 1 tab "Remark" đi kèm để pà kon hiểu định nghĩa của tính tiền công í;
Mình có chỉnh code của bạn một chút. Nói thiệt là chỉnh cái đơn giản thôi chứ tự ghi lên thì ko hiểu nên ko làm được.

 

[snow25]

Cảm ơn rất nhiều, và nhiều lắm luôn. Mình chạy ra files được rồi.

Có thể "đòi hỏi giúp thêm chút" nữa ko? Hehe
- Mình muốn toàn bộ dữ liệu từ hàng số 9 trở lên là được giữ nguyên - tức là có tựa đề
- Format vẫn giữ nguyên được ko? Tức có kẽ ngang, kẽ dọc í;
- Và cuối cùng là Mỗi file tách ra có 1 tab "Remark" đi kèm để pà kon hiểu định nghĩa của tính tiền công í;
Mình có chỉnh code của bạn một chút. Nói thiệt là chỉnh cái đơn giản thôi chứ tự ghi lên thì ko hiểu nên ko làm được.

Đây bạn xem.