nhờ giúp insert row

[quocphu67]

Em có file số liệu đính kèm. đây là file lấy mẫu trong các lỗ khoan.
trong đấy cột A là tên lỗ khoan
cột B là số hiệu mẫu
côt C và D là khoảng từ và đến (khoảng lấy mẫu)
cột F là giá trị phân tích mẫu.
em có vấn đề như thế này
em muốn (khoảng lấy mẫu phải nhỏ hơn hoặc bằng 1) nhưng ở đây ví dụ ở ô C12 và D12 khoảng lấy mẫu là 6,7 (>1)
em muốn insert thêm các cột đằng sau nó và lũy tiến C12=D11; D12=C12+1 ... cho đến khi Dn-Cn (khoảng lấy mẫu) <=1. Và các ô A12=A11, B12="AK", E12=0 (tương tự với cáo row lũy tiến đằng sau)

kết quả sau khi chạy ra sẽ giống kết quả nằm bên sheet "ket qua"

Các chuyên gia giúp em lập maco chạy với ạ. em cảm ơn.

 

[SA_DQ]

Chu trình này ta nên chia làm nhiều công đoạn;
Sau đây mình giúp bạn công đoạn đầu tiên là xác định số dòng cần thêm & ghi vô cột [G] của CSDL của bạn;
Việc này được macro sau đây thực hiện:

Sub XacDinhSoDongThemTheoHieu2Cot_E_D()
Dim Rws As Long, J As Long

Rws = [e1].CurrentRegion.Rows.Count
For J = 2 To Rws
    If Cells(J, "E").Value > 1 + Cells(J, "D").Value Then
        Cells(J, "G").Value = Int(Int(1 + Cells(J, "E").Value) - Cells(J, "D").Value)
    End If
Next J
End Sub

Bạn xem số liệu do macro ghi đã đúng chưa, để ta còn tiếp tục.

Ghi chú: CSDL nên có tiêu đề & cột STT để bạn cùng diễn đàn trao đổi thông tin nhanh tiện hơn
& chúc vui!

 

[CHAOQUAY]

Em có file số liệu đính kèm. đây là file lấy mẫu trong các lỗ khoan.
trong đấy cột A là tên lỗ khoan
cột B là số hiệu mẫu
côt C và D là khoảng từ và đến (khoảng lấy mẫu)
cột F là giá trị phân tích mẫu.
em có vấn đề như thế này
em muốn (khoảng lấy mẫu phải nhỏ hơn hoặc bằng 1) nhưng ở đây ví dụ ở ô C12 và D12 khoảng lấy mẫu là 6,7 (>1)
em muốn insert thêm các cột đằng sau nó và lũy tiến C12=D11; D12=C12+1 ... cho đến khi Dn-Cn (khoảng lấy mẫu) <=1. Và các ô A12=A11, B12="AK", E12=0 (tương tự với cáo row lũy tiến đằng sau)

kết quả sau khi chạy ra sẽ giống kết quả nằm bên sheet "ket qua"

Các chuyên gia giúp em lập maco chạy với ạ. em cảm ơn.

Bạn test thử code này xem sao

Public Sub InsertRows()
Dim Source As Variant
Dim Result As Variant
Dim i As Long, ii As Long, j As Long, jj As Long, rw As Long, z As Double
Source = Sheet1.Range("A1").CurrentRegion
ReDim Result(1 To 10000, 1 To UBound(Source, 2) + 1)
For i = 1 To UBound(Source)
    If Source(i, 4) - Source(i, 3) <= 1 Then
        rw = rw + 1
        For j = 1 To UBound(Source, 2)
            Result(rw, j) = Source(i, j)
        Next j
    Else
        For j = 1 To UBound(Source, 2)
            Result(rw + 1, j) = Source(i, j)
        Next j
        Result(rw + 1, 4) = Result(rw + 1, 3) + 1
        z = Source(i, 4) - Source(i, 3) - Int(Source(i, 4) - Source(i, 3))
        If z = 0 Then
            jj = Int(Source(i, 4) - Source(i, 3)) - 1
        Else
            jj = Int(Source(i, 4) - Source(i, 3))
        End If
        For ii = rw + 2 To rw + 2 + jj - 1
            For j = 1 To UBound(Source, 2)
                Result(ii, j) = Result(ii - 1, j)
            Next j
            Result(ii, 3) = Result(ii - 1, 4)
            Result(ii, 4) = Result(ii, 3) + 1
            rw = ii
        Next ii
        Result(rw, 4) = Source(i, 4)
    End If
Next i
With Sheet2
.Range("g1").Resize(rw, UBound(Result, 2)).ClearContents
.Range("g1").Resize(rw, UBound(Result, 2)) = Result
.Columns.AutoFit
End With
End Sub

 

[quocphu67]

Bạn test thử code này xem sao

Cảm ơn bác. em làm được rồi.