[Giúp] VBA Tự insert ngày dựa vào ngày Start và ngày End

robinhsoon · 3/6/19

Thân chào cả nhà GPEX!

Mong cả nhà giúp em một việc ạ..
Hiện tại em có một File bao gồm hơn 10 sheet, Em lấy 02 Sheet làm Demo ạ..

Từ File có sẵn Em muốn Dựa vào ngày Start và End (Cột I và J, em đã Tô màu Vàng) sẽ tự Insert thêm dòng.

Ví dụ:
Ngày Start là ngày 25/03 và ngày End là ngày 27/03 thì sẽ tự Insert thêm 02 dòng là ngày 26/03 và ngày 27/03

Em có làm Ví dụ ở Sheet Kết Quả..

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

snow25 · 3/6/19

robinhsoon đã viết:
Thân chào cả nhà GPEX!

Mong cả nhà giúp em một việc ạ..
Hiện tại em có một File bao gồm hơn 10 sheet, Em lấy 02 Sheet làm Demo ạ..

Từ File có sẵn Em muốn Dựa vào ngày Start và End (Cột I và J, em đã Tô màu Vàng) sẽ tự Insert thêm dòng.

Ví dụ:
Ngày Start là ngày 25/03 và ngày End là ngày 27/03 thì sẽ tự Insert thêm 02 dòng là ngày 26/03 và ngày 27/03

Em có làm Ví dụ ở Sheet Kết Quả..

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

Bạn chạy thử cái ngu ngu này.

Mã:

Sub linhtinh()
    Dim sh As Worksheet, i As Long, j As Long, b As Long, lr As Long, a As Long, arr, arr1, k As Long
    For Each sh In ThisWorkbook.Worksheets
        a = 0
        lr = sh.Range("A" & Rows.Count).End(xlUp).Row
        If lr > 3 Then
           arr = sh.Range("A4:J" & lr).Value
           ReDim arr1(1 To UBound(arr, 1) * 5, 1 To UBound(arr, 2))
               For i = 1 To UBound(arr, 1)
                   b = CLng(CDate(arr(i, 10))) - CLng(CDate(arr(i, 9)))
                         For k = 0 To b
                             a = a + 1
                             For j = 1 To 8
                                 arr1(a, j) = arr(i, j)
                             Next j
                                 arr1(a, 9) = Format(CLng(CDate(arr(i, 9))) + k, "dd-mm-yyyy")
                                 arr1(a, 10) = Format(arr(i, 10), "DD-mm-yyyy")
                        Next k
              Next i
          sh.Range("A4:J4").Resize(a).Value = arr1
      End If
 Next
End Sub

leonguyenz · 3/6/19

robinhsoon đã viết:
Thân chào cả nhà GPEX!

Mong cả nhà giúp em một việc ạ..
Hiện tại em có một File bao gồm hơn 10 sheet, Em lấy 02 Sheet làm Demo ạ..

Từ File có sẵn Em muốn Dựa vào ngày Start và End (Cột I và J, em đã Tô màu Vàng) sẽ tự Insert thêm dòng.

Ví dụ:
Ngày Start là ngày 25/03 và ngày End là ngày 27/03 thì sẽ tự Insert thêm 02 dòng là ngày 26/03 và ngày 27/03

Em có làm Ví dụ ở Sheet Kết Quả..

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

Thêm 1 code tham khảo:

Mã:

Sub Button1_Click()
Dim wS As Worksheet, sArr(), i As Long, j As Long, k As Long
Dim reArr(1 To 5000, 1 To 10), m As Long, n As Long, LsR As Long
Sheets("KetQua").Range("A4:J5000").ClearContents
For Each wS In ThisWorkbook.Worksheets
    If wS.Name <> "KetQua" Then
        LsR = wS.Range("A65535").End(xlUp).Row
        sArr = wS.Range("A4:J" & LsR).Value
        For i = 1 To UBound(sArr, 1)
            m = sArr(i, 10) - sArr(i, 9)
            If m Then
                For n = 1 To m + 1
                    k = k + 1
                    For j = 1 To 8
                        reArr(k, j) = sArr(i, j)
                    Next j
                    reArr(k, 9) = sArr(i, 9) + n - 1
                    reArr(k, 10) = sArr(i, 9) + n - 1
                Next n
            Else
                k = k + 1
                For j = 1 To 10
                    reArr(k, j) = sArr(i, j)
                Next j
            End If
        Next i
    End If
Next
If k Then Sheets("KetQua").Range("A4").Resize(k, 10) = reArr
End Sub

robinhsoon · 3/6/19

leonguyenz đã viết:

Thêm 1 code tham khảo:

Mã:

Sub Button1_Click()
Dim wS As Worksheet, sArr(), i As Long, j As Long, k As Long
Dim reArr(1 To 5000, 1 To 10), m As Long, n As Long, LsR As Long
Sheets("KetQua").Range("A4:J5000").ClearContents
For Each wS In ThisWorkbook.Worksheets
    If wS.Name <> "KetQua" Then
        LsR = wS.Range("A65535").End(xlUp).Row
        sArr = wS.Range("A4:J" & LsR).Value
        For i = 1 To UBound(sArr, 1)
            m = sArr(i, 10) - sArr(i, 9)
            If m Then
                For n = 1 To m + 1
                    k = k + 1
                    For j = 1 To 8
                        reArr(k, j) = sArr(i, j)
                    Next j
                    reArr(k, 9) = sArr(i, 9) + n - 1
                    reArr(k, 10) = sArr(i, 9) + n - 1
                Next n
            Else
                k = k + 1
                For j = 1 To 10
                    reArr(k, j) = sArr(i, j)
                Next j
            End If
        Next i
    End If
Next
If k Then Sheets("KetQua").Range("A4").Resize(k, 10) = reArr
End Sub

Em cảm ơn Thầy đã quan tâm giúp đỡ em ạ, Hiện tại code rất nhanh và hay ạ, Em muốn sửa một ít được không ạ, Em muốn nó chỉ làm việc trên các Sheet có Tên Project & i (Sheet kết quả vẫn giữ như vậy) thôi ạ.. Vì hiện tại code nó làm việc trên tất cả các sheet, khi em insert ra sheet khác nó lại báo lỗi ạ..

Em cảm ơn Thầy rất nhiều ạ

Bài đã được tự động gộp: 3/6/19

snow25 đã viết:

Bạn chạy thử cái ngu ngu này.

Mã:

Sub linhtinh()
    Dim sh As Worksheet, i As Long, j As Long, b As Long, lr As Long, a As Long, arr, arr1, k As Long
    For Each sh In ThisWorkbook.Worksheets
        a = 0
        lr = sh.Range("A" & Rows.Count).End(xlUp).Row
        If lr > 3 Then
           arr = sh.Range("A4:J" & lr).Value
           ReDim arr1(1 To UBound(arr, 1) * 5, 1 To UBound(arr, 2))
               For i = 1 To UBound(arr, 1)
                   b = CLng(CDate(arr(i, 10))) - CLng(CDate(arr(i, 9)))
                         For k = 0 To b
                             a = a + 1
                             For j = 1 To 8
                                 arr1(a, j) = arr(i, j)
                             Next j
                                 arr1(a, 9) = Format(CLng(CDate(arr(i, 9))) + k, "dd-mm-yyyy")
                                 arr1(a, 10) = Format(arr(i, 10), "DD-mm-yyyy")
                        Next k
              Next i
          sh.Range("A4:J4").Resize(a).Value = arr1
      End If
Next
End Sub

Em cảm ơn anh đã quan tâm ạ, em muốn xuất kết quả ra sheet Ket qua và chỉ làm việc cho các sheet có tên Project & i thôi ạ..

Mong Anh giúp đỡ ạ..

Ba Tê · 3/6/19

robinhsoon đã viết:
Em cảm ơn Thầy đã quan tâm giúp đỡ em ạ, Hiện tại code rất nhanh và hay ạ, Em muốn sửa một ít được không ạ, Em muốn nó chỉ làm việc trên các Sheet có Tên Project & i (Sheet kết quả vẫn giữ như vậy) thôi ạ.. Vì hiện tại code nó làm việc trên tất cả các sheet, khi em insert ra sheet khác nó lại báo lỗi ạ..

Em cảm ơn Thầy rất nhiều ạ

Bài đã được tự động gộp: 3/6/19

Em cảm ơn anh đã quan tâm ạ, em muốn xuất kết quả ra sheet Ket qua và chỉ làm việc cho các sheet có tên Project & i thôi ạ..

Mong Anh giúp đỡ ạ..

Bạn thử với Sub này xem.

PHP:

Public Sub sGpe()
Const CoL As Long = 10
Dim Ws As Worksheet, sArr(), dArr(1 To 10000, 1 To CoL), fDate As Long, eDate As Long
Dim I As Long, J As Long, K As Long, N As Long, R As Long
For Each Ws In ThisWorkbook.Worksheets
    If Ws.Name <> "KetQua" Then
        With Ws
            If .Range("A10000").End(xlUp).Row > 3 Then
                sArr = .Range("A4", .Range("A10000").End(xlUp)).Resize(, CoL).Value
                R = UBound(sArr)
                For I = 1 To R
                    fDate = sArr(I, 9)
                    eDate = sArr(I, 10)
                    For N = fDate To eDate
                        K = K + 1
                        For J = 1 To CoL - 1
                            dArr(K, J) = sArr(I, J)
                        Next J
                        dArr(K, CoL - 1) = N
                        dArr(K, CoL) = eDate
                    Next N
                Next I
            End If
        End With
    End If
Next Ws
With Sheets("KetQua")
    .Range("A4").Resize(10000, CoL).ClearContents
    .Range("A4").Resize(K, CoL) = dArr
    '......................................'
End With
End Sub

leonguyenz · 3/6/19

robinhsoon đã viết:
Em muốn nó chỉ làm việc trên các Sheet có Tên Project & i (Sheet kết quả vẫn giữ như vậy) thôi ạ.. Vì hiện tại code nó làm việc trên tất cả các sheet, khi em insert ra sheet khác nó lại báo lỗi ạ..

Bạn sửa đoạn sau:

Mã:

If wS.Name <> "KetQua" And InStr(wS.Name, "Project") Then

Phuocam · 3/6/19

Hoặc cũng có thể dùng:

Mã:

If wS.Name Like "Project*") Then

snow25 · 3/6/19

leonguyenz đã viết:
Bạn sửa đoạn sau:

Mã:

If wS.Name <> "KetQua" And InStr(wS.Name, "Project") Then

Em nghĩ chỉ cần lấy vế sau của if là đủ nhỉ anh.

Ba Tê · 3/6/19

Nếu còn nhiều sheet "lubu" khác trong file thì tôi "khoái" và sẽ viết như bài #7.

robinhsoon đã viết:
chỉ làm việc cho các sheet có tên Project & i thôi ạ..

Vì trong file có sheet "Total Project" hay đại loại thế thì Instr() chưa chắc ăn.
Mà lỡ có sheet "Project Huhu Hichic" thì thứ nào cũng "tèo".
Nói chung là phải biết rõ trong "hồ lô chứa cái gì".

robinhsoon · 5/6/19

Ba Tê đã viết:
Nếu còn nhiều sheet "lubu" khác trong file thì tôi "khoái" và sẽ viết như bài #7.

Vì trong file có sheet "Total Project" hay đại loại thế thì Instr() chưa chắc ăn.
Mà lỡ có sheet "Project Huhu Hichic" thì thứ nào cũng "tèo".
Nói chung là phải biết rõ trong "hồ lô chứa cái gì".

Em cảm ơn Các Thầy đã giúp đỡ em ạ, Code rất hay và nhanh.

Chúc các Thầy sức khỏe và thành công ạ.

[Giúp] VBA Tự insert ngày dựa vào ngày Start và ngày End

robinhsoon

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

File đính kèm

snow25

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

leonguyenz

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

File đính kèm

robinhsoon

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

Ba Tê

Cạo Rồi Khỏi Gội

leonguyenz

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

Phuocam

Thành viên mới

snow25

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

Ba Tê

Cạo Rồi Khỏi Gội

robinhsoon

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

Đếm ngược thời gian