Cần giúp đỡ thu gọn VBA

[hiv174]

em không có kiến thức về VBA và chỉ làm theo cóp nhặt nên mong mọi người giúp đỡ chỉnh sửa hoặc làm lại giúp ạ.
file mô tả phần nào em đính kèm bên dưới mong ai có chuyên môn có thể giúp em, em xin chân thành cảm ơn.
Mong mọi người có thể giúp em ( vì không có kiến thức nên có thể trong câu nói của em chưa rõ nghĩa mong mọi người thông cảm đưa ra ý kiến để em bổ xung ạ)
1: vì số dòng không cố định nên hết 1 chu kỳ dữ liệu sẽ tự xuống dòng nhưng không ghi đè lên dư liệu vừa tạo.
2: có thể tùy biến chọn vùng dư liệu ( 2 hoặc 3 hoặc 4 cột và n dòng 1 chu kỳ)
vd: chọn 2 cột thì hết 1 chu kỳ dữ liệu mới sẽ xuống dòng và bắt đầu tạo dư liệu từ dòng thứ 3 của sheet mới, chọn 3 cột thì bắt đầu từ dòng thứ 4.
3: có thể tùy biến số cột mỗi chu kỳ( trong file của em đang để là 90)
Em xin chân thành cảm ơn và mong nhận được sự giúp đỡ.

 

[tonnydung]

nhờ cả nhà giúp cái vba tu dong coppy này giup em voi ah. Vi dữ liệu em nhiều cột có công thức mà dữ liệu lớn nên em nhờ các bác giúp code coppy trong cung 1 Sheet với điều kiện như sau:
Em muốn coppy cong thức cửa 5 cột (cột E,Y,X,AB) từ hàng trên xuống hàng dưới khi cột B của hàng dưới có dữ liệu.
Vd: nếu nhập vào địa chỉ B4 số hay ký tự bất kỳ thi sẽ tự động coppy công thức của E3,Y3,X3,AB3 xuống lần luọt E4,Y4,X4,AB4
Rất mong các bác giúp.

 

[phulien1902]

nhờ cả nhà giúp cái vba tu dong coppy này giup em voi ah. Vi dữ liệu em nhiều cột có công thức mà dữ liệu lớn nên em nhờ các bác giúp code coppy trong cung 1 Sheet với điều kiện như sau:
Em muốn coppy cong thức cửa 5 cột (cột E,Y,X,AB) từ hàng trên xuống hàng dưới khi cột B của hàng dưới có dữ liệu.
Vd: nếu nhập vào địa chỉ B4 số hay ký tự bất kỳ thi sẽ tự động coppy công thức của E3,Y3,X3,AB3 xuống lần luọt E4,Y4,X4,AB4
Rất mong các bác giúp.

Thử:

Private Sub Worksheet_Change(ByVal Target As Range)
   If Not Intersect(Target, Range("E3:E" & Cells(Rows.Count, "E").End(xlUp).Row)) Is Nothing Then
        abc
    End If
End Sub
Sub abc()
    Dim LR
    With Sheets(1)
        LR = .Cells(Rows.Count, "E").End(xlUp).Row
        If LR < 3 Then LR = 3
        .Range("E4:E" & LR).FormulaR1C1 = "Cong thuc 1" ' Nhap cong thuc vao day
        .Range("I4:I" & LR).FormulaR1C1 = "Cong thuc 2" ' Nhap cong thuc vao day
        .Range("X4:X" & LR).FormulaR1C1 = "Cong thuc 3" ' Nhap cong thuc vao day
        .Range("AB4:AB" & LR).FormulaR1C1 = "Cong thuc 4" 'Nhap cong thuc vao day
    End With
End Sub

 

[tonnydung]

Thử:

Private Sub Worksheet_Change(ByVal Target As Range)
   If Not Intersect(Target, Range("E3:E" & Cells(Rows.Count, "E").End(xlUp).Row)) Is Nothing Then
        abc
    End If
End Sub
Sub abc()
    Dim LR
    With Sheets(1)
        LR = .Cells(Rows.Count, "E").End(xlUp).Row
        If LR < 3 Then LR = 3
        .Range("E4:E" & LR).FormulaR1C1 = "Cong thuc 1" ' Nhap cong thuc vao day
        .Range("I4:I" & LR).FormulaR1C1 = "Cong thuc 2" ' Nhap cong thuc vao day
        .Range("X4:X" & LR).FormulaR1C1 = "Cong thuc 3" ' Nhap cong thuc vao day
        .Range("AB4:AB" & LR).FormulaR1C1 = "Cong thuc 4" 'Nhap cong thuc vao day
    End With
End Sub

Tks bác nhưng không phải set cột B ah ?

 

[phulien1902]

Tks bác nhưng không phải set cột B ah ?

Tôi không hiểu ý bạn nói gì.

 

[tonnydung]

Tôi không hiểu ý bạn nói gì.

Dạ vì lệnh chỉ coppy khi có dữ liệu ở cột B4 nên em không thấy có chỗ nào trong code set về cột này nên em hỏi có cần phải set cột B không ah ?

 

[phulien1902]

Dạ vì lệnh chỉ coppy khi có dữ liệu ở cột B4 nên em không thấy có chỗ nào trong code set về cột này nên em hỏi có cần phải set cột B không ah ?

Tôi đã hiểu, vậy bạn thay dòng:

LR = .Cells(Rows.Count, "E").End(xlUp).Row

bằng dòng:

LR = .Cells(Rows.Count, "B").End(xlUp).Row

Vậy thôi, và bạn thử gõ cái gì đó vào cột E, rồi Enter xem.

 

[tonnydung]

Tôi đã hiểu, vậy bạn thay dòng:

LR = .Cells(Rows.Count, "E").End(xlUp).Row

bằng dòng:

LR = .Cells(Rows.Count, "B").End(xlUp).Row

Vậy thôi, và bạn thử gõ cái gì đó vào cột E, rồi Enter xem.

Công thức của em đây:

Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Range("B3:B" & Cells(Rows.Count, "B").End(xlUp).Row)) Is Nothing Then
abc
End If
End Sub
Sub abc()
Dim LR
With Sheets("SothuQuy")
LR = .Cells(Rows.Count, "B").End(xlUp).Row
If LR < 3 Then LR = 3
.Range("K4:K" & LR).FormulaR1C1 = "=IF(LEFT($F4,3)=111,$J4,0)"
.Range("L4:L" & LR).FormulaR1C1 = "=IF(LEFT($G4,3)=111,$J4,0)" ' Nhap cong thuc vao day
.Range("M4:M" & LR).FormulaR1C1 = "=IF(K4+L4=0,0,$K$1+SUM(K$3:$K4)-SUM(L$3:$L4))" ' Nhap cong thuc vao day

End With
End Sub

Nhung báo lỗi

 

[VetMini]

...
Nhung báo lỗi

Học đến trình độ này rồi mà còn hỏi một câu suông "báo lỗi" à?
Trong nghề lập trình, phải luôn tâm niệm câu: "giải thích vấn đề càng rõ thì càng mau thấy/nhận được giải đáp". Lắm lúc viết được vấn đề của mình ra giấy xong là tự thấy câu trả lời.

 

[phulien1902]

Công thức của em đây:

Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Range("B3:B" & Cells(Rows.Count, "B").End(xlUp).Row)) Is Nothing Then
abc
End If
End Sub
Sub abc()
Dim LR
With Sheets("SothuQuy")
LR = .Cells(Rows.Count, "B").End(xlUp).Row
If LR < 3 Then LR = 3
.Range("K4:K" & LR).FormulaR1C1 = "=IF(LEFT($F4,3)=111,$J4,0)"
.Range("L4:L" & LR).FormulaR1C1 = "=IF(LEFT($G4,3)=111,$J4,0)" ' Nhap cong thuc vao day
.Range("M4:M" & LR).FormulaR1C1 = "=IF(K4+L4=0,0,$K$1+SUM(K$3:$K4)-SUM(L$3:$L4))" ' Nhap cong thuc vao day

End With
End Sub

Nhung báo lỗi

Báo lỗi là phải rồi, nhìn cũng biết mà, hơn nữa bài #21 khác bài #27.
Tôi không giúp gì được cho bạn rồi.