Thêm bớt dòng có điều kiện

[hpmongmanh]

Chào tất cả ACE yêu GPE
Mình có 1 bảng tính như sau : xem file đính kèm
Trên 1 sheet có 2 bảng mối bảng có 6 cột và 1 dòng cố định (dòng tiêu đề), ví dụ ô C2 gõ 4 và C3 gõ 5 thì lần lướt bảng 1 thêm 4 dòng, bảng 2 thêm 5 dòng. Khi thêm dòng ở bảng 1 thì dòng cố định ở bảng 2 bị đẩn xuống, ngước lại khi bớt dòng thì dòng cố định của bảng 2 được kéo lên. Tương tự thêm bớt dỏng bảng 2 cũng thế nhứng gì ở dưới bảng 2 vẫn y nguyên.
Rất mỏng được ACE trợ giúp
Xin trân trọng cảm ơn
Thái Châu

 

[ndu96081631]

Chào tất cả ACE yêu GPE
Mình có 1 bảng tính như sau : xem file đính kèm
Trên 1 sheet có 2 bảng mối bảng có 6 cột và 1 dòng cố định (dòng tiêu đề), ví dụ ô C2 gõ 4 và C3 gõ 5 thì lần lướt bảng 1 thêm 4 dòng, bảng 2 thêm 5 dòng. Khi thêm dòng ở bảng 1 thì dòng cố định ở bảng 2 bị đẩn xuống, ngước lại khi bớt dòng thì dòng cố định của bảng 2 được kéo lên. Tương tự thêm bớt dỏng bảng 2 cũng thế nhứng gì ở dưới bảng 2 vẫn y nguyên.
Rất mỏng được ACE trợ giúp
Xin trân trọng cảm ơn
Thái Châu

Thường những ai làm việc nhiều với Excel thì chẳng người nào thiết kế 2 bảng dữ liệu nằm cùng cột như kiểu của bạn đâu (vì rất khó xử lý sau này)
Nói chung yêu cầu của bạn chẳng khó khăn gì, có điều tôi muốn biết MỤC ĐÍCH CUỐI CÙNG CỦA BẠN LÀ ĐỂ LÀM CÁI GÌ VẬY? (biết đâu có thể tư vấn bạn cách khác hay hơn)

 

[hpmongmanh]

Thường những ai làm việc nhiều với Excel thì chẳng người nào thiết kế 2 bảng dữ liệu nằm cùng cột như kiểu của bạn đâu (vì rất khó xử lý sau này)
Nói chung yêu cầu của bạn chẳng khó khăn gì, có điều tôi muốn biết MỤC ĐÍCH CUỐI CÙNG CỦA BẠN LÀ ĐỂ LÀM CÁI GÌ VẬY? (biết đâu có thể tư vấn bạn cách khác hay hơn)

Cảm ơn anh, đúng là nghe rất khó hiểu nhưng đây là 1 báo cáo thực sự, vì là danh sách chí cần đến tối đa 12 người mỗi table nên xếp trên 1 hàng. Cụ thể table 1 là thông tin do nội bộ cung cấp, table 2 là thông tin do cộng tác viên cung cấp, cả 2 table với tổng số người là điều kiện đã được đếm từ 1 sheet nhập liệu.
Rất mong được giúm đỡ
Trân trọng cảm ơn.

 

[thanh tong]

Bạn dùng lệnh insert cho nhanh cần gì phải làm như vậy cho mất thời gian

 

[hpmongmanh]

Bạn dùng lệnh insert cho nhanh cần gì phải làm như vậy cho mất thời gian

Đây là chuyên mục VBA, trả lời thề này thì trả lời làm gì...................

Để mô tả rõ hơn xin gửi bạn ndu96081631 file mới để giúp đỡ, và cũng mong tất cả ace cùng tham gia đóng góp.
Hãy xem file đính kèm để rõ mục đính hơn.

 

[SA_DQ]

Thay vì xóa & thêm dòng, ta có thể ẩn hay hiện lại các dòng cần thiết theo số liệu ô

Có vậy ta đỡ fải thực hiện công đoạn format Border; Chỉ có điều là ta để số dòng ở 2 bảng đã được kẻ khung là tối đa; Macro chỉ làm việc ẩn đi những dòng thừa hay hiện thêm 1 số dòng còn thiếu; Để thực thi fương án này tốt nhất, bạn nên cho biết trị lớn nhất của bảng A & bảng B sẽ là bao nhiêu thì đặng(?) Chờ í của bạn!

 

[adua29]

Bạn xem mình làm thế này có được không.
Đây là phương pháp mình hay làm để in hoá đơn bán hàng.

 

[hpmongmanh]

Bạn xem mình làm thế này có được không.
Đây là phương pháp mình hay làm để in hoá đơn bán hàng.

Không phải thế này, dù sao cũng cảm ơn.

 

[hpmongmanh]

Có vậy ta đỡ fải thực hiện công đoạn format Border; Chỉ có điều là ta để số dòng ở 2 bảng đã được kẻ khung là tối đa; Macro chỉ làm việc ẩn đi những dòng thừa hay hiện thêm 1 số dòng còn thiếu; Để thực thi fương án này tốt nhất, bạn nên cho biết trị lớn nhất của bảng A & bảng B sẽ là bao nhiêu thì đặng(?) Chờ í của bạn!

BC của mình chỉ trong khổ A4, thông thường mỗi bảng tối đa 12 dòng, ở dưới cùng một vài thông tin rồi là ký tên.
Xem file mới : http://www.mediafire.com/?0u4mp51benx2alp

 

[ChanhTQ@]

Bạn xài macro sự kiện này

(Ứng với file bạn đưa lên cuối cùng:= Chọn tháng tại [E2])

Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
 If Not Intersect(Target, [E2]) Is Nothing Then
   Dim hRw As Byte
   
   [c9].Resize(30).EntireRow.Hidden = False
   If [f4].Value < 12 Then
      hRw = 9 + Choose(1 + [f4].Value, 0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11)
      Cells(hRw, 1).Resize(21 - hRw).EntireRow.Hidden = True
   End If
   If [f5].Value < 12 Then
      hRw = 25 + Choose(1 + [f5].Value, 0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11)
      Cells(hRw, 1).Resize(37 - hRw).EntireRow.Hidden = True
   End If
 End If
End Sub

 

[adua29]

bc của mình chỉ trong khổ a4, thông thường mỗi bảng tối đa 12 dòng, ở dưới cùng một vài thông tin rồi là ký tên.
Xem file mới : http://www.mediafire.com/?0u4mp51benx2alp

cho mình hỏi có phải ý bạn muốn là mỗi bản đều có một số dòng trống và vị trí của thông tin cuối trang là không thay đổi giống như một hoá đơn bán hàng cho dù số lượng hàng có thay đổi có phải không (phần ký tên luôn cố định tại một vị trí trên trang a4)?

Nếu đúng như vậy thì mình xử lý như sau. Bạn xem lại nhé.

À mình quên mất điều kiện dòng tiêu đề 2 di động của bạn, nếu vậy bạn di chuyển 12 dòng mình thêm dưới bảng 1 xuống phía dưới bảng 2 và điều chỉnh lại công thức trong các 24 dòng mình đã thêm vào là được. Chúc thành công.

Đã chót thì chét. Mình hoàn chỉnh luôn đây. Chúc bạn vui vẻ.

 

[jlx2002-ls]

Gửi các bạn quan tâm,

Ngẫm mãi mởi hiểu ý bạn hpmongmanh, chắc chắn không sai, xin mời copy đoạn code này rồi paste vào sheet1 code, à mà gửi luôn file đính kèm. Còn các bạn khác đọc ký trước khi trả lời nhé.

Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
    Dim xList_One As Integer, xList_Two As Integer
 
    Dim iLoop As Integer, xNumber As Integer
    Dim myRange As Range
   'Set myRange = Intersect(Range("F4:F5"), Target)
 
   'If Not myRange Is Nothing Then
    If Not Intersect(Target, Range("e2")) Is Nothing Then
     Application.ScreenUpdating = False
     Application.EnableEvents = False
        If [so1] > 0 Then
            xList_One = Mid(ActiveWorkbook.Names(1), InStrRev(ActiveWorkbook.Names(1), "$") + 1, Len(ActiveWorkbook.Names(1)) - (InStrRev(ActiveWorkbook.Names(1), "$")))
            xList_Two = Mid(ActiveWorkbook.Names(2), InStrRev(ActiveWorkbook.Names(2), "$") + 1, Len(ActiveWorkbook.Names(2)) - (InStrRev(ActiveWorkbook.Names(2), "$")))
            xNumber = xList_Two - 4 - xList_One
            If Range("so1") > xNumber Then
                For iLoop = 1 To Range("so1") - xNumber
                    Rows("9:9").Select
                    Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
                    With Selection.Interior
                 .ColorIndex = xlNone
                    End With
                Next
            ElseIf Range("so1") < xNumber Then
                For iLoop = 1 To xNumber - Range("so1")
                    Rows("9:9").Select
                    Selection.Delete Shift:=xlUp
                Next
            End If
            'Range("B9").Select
        End If
        If [so2] > 0 Then
            Range(Range("bang2").Address & ":h50").Select
            With Selection
                .Borders(xlDiagonalDown).LineStyle = xlNone
                .Borders(xlDiagonalUp).LineStyle = xlNone
                .Borders(xlEdgeLeft).LineStyle = xlNone
                .Borders(xlEdgeTop).LineStyle = xlNone
                .Borders(xlEdgeBottom).LineStyle = xlNone
                .Borders(xlEdgeRight).LineStyle = xlNone
                .Borders(xlInsideVertical).LineStyle = xlNone
                .Borders(xlInsideHorizontal).LineStyle = xlNone
            End With
            Range(Range("bang2").Address & ":h" & Range("bang2").Row + Range("so2").Value).Select
            Selection.Borders(xlDiagonalDown).LineStyle = xlNone
            Selection.Borders(xlDiagonalUp).LineStyle = xlNone
            With Selection.Borders(xlEdgeLeft)
                .LineStyle = xlContinuous
                .ColorIndex = xlAutomatic
 
                .Weight = xlThin
            End With
            With Selection.Borders(xlEdgeTop)
                .LineStyle = xlContinuous
                .ColorIndex = xlAutomatic
 
                .Weight = xlThin
            End With
            With Selection.Borders(xlEdgeBottom)
                .LineStyle = xlContinuous
                .ColorIndex = xlAutomatic
 
                .Weight = xlThin
            End With
            With Selection.Borders(xlEdgeRight)
                .LineStyle = xlContinuous
                .ColorIndex = xlAutomatic
 
                .Weight = xlThin
            End With
            With Selection.Borders(xlInsideVertical)
                .LineStyle = xlContinuous
                .ColorIndex = xlAutomatic
 
                .Weight = xlThin
            End With
            With Selection.Borders(xlInsideHorizontal)
                .LineStyle = xlContinuous
                .ColorIndex = xlAutomatic
 
                .Weight = xlThin
            End With
        End If
    End If
    Range("e3").Select
    Application.EnableEvents = True
    Application.ScreenUpdating = True
End Sub
Sub cc()
Application.EnableEvents = True
End Sub

 

[SA_DQ]

Nên "đặt thừa số chung", 1 khi fát hiện ra quy luật!

Vì các tham số xlEdgeLeft , xlEdgeTop, xlEdgeBottom, xlEdgeRight, xlInsideVertical & xlInsideHorizontal
fát triển theo 1 quy luật; Nên ta có thể viết gọn lài macro này bằng cách tạo thêm 1 macro con & truyền nó nó tham số để nó định dạng 6 lần

Chúc vui cuối tuần!

 

[concogia]

Nếu đúng như thế..

Xin phép mượn file của bạn jlx2002-ls
Chưa biết chủ topic nhập liệu ra làm sao nhưng với những điều kiện trong file giả lập trên ta có thể làm thế này chắc .....cũng ổn

Private Sub Worksheet_Change(ByVal Target As Range)
  Dim iHai As Integer
    If Target.Address = "$E$2" Then
       iHai = Application.WorksheetFunction.Match("STT", [c9:c50], 0) + 6
       If iHai > 11 Then Range("10:" & iHai - 2).Delete Shift:=xlUp
       [c9].Resize([f4] - 1).EntireRow.Insert
       [c9].Resize([f4], 6).Interior.ColorIndex = xlNone
            iHai = Application.WorksheetFunction.Match("STT", [c9:c50], 0) + 10
            Range(iHai & ":50").Delete
            Cells(iHai - 1, 3).Resize([f5] - 1).EntireRow.Insert
            Cells(iHai - 1, 3).Resize([f5], 6).Interior.ColorIndex = xlNone
    End If
End Sub

 

[sealand]

Code các bạn viết hơi dài, mình tham gia như sau:

Private Sub Worksheet_Change(ByVal Target As Range)
Dim i, Rg1 As Range, Rg2 As Range
Application.ScreenUpdating = False
If Target.Address = "$E$2" Then
Set Rg1 = Columns(3).Find(what:="STT")
Set Rg2 = Columns(3).FindNext(after:=Rg1)
Rg2.Offset(2).Resize(20, 6).Delete
Rg2.Offset(1).Resize(, 6).Copy Rg2.Offset(1).Resize([F5], 6)
If Rg2.Row - Rg1.Row > 4 Then Rows(Rg1.Row + _
1 & ":" & Rg2.Row - 3).EntireRow.Delete
For i = 1 To [F4]
Rg1.Offset(1).EntireRow.Insert
Set Rg2 = Columns(3).FindNext(after:=Rg1)
Rg2.Offset(1).EntireRow.Copy Rg1.Offset(1, -2)
Next
End If
Set Rg1 = Nothing: Set Rg2 = Nothing
End Sub

Hi, khi gửi chưa biết Concogia còn "nghèo" hơn

 

[hpmongmanh]

Méc xi các bác vô cùng nhiều,
Các bác đã làm đúng ý em y sì fóc, nhưng có điều tất cả những gì phía dưới bảng 2 như chữ ký, thống kê ... bị xoá sạch. Mong các bác dùng tuyệt chiêu 1 lần nữa.
Vô cùng méc xi.

 

[Ba Tê]

Méc xi các bác vô cùng nhiều,
Các bác đã làm đúng ý em y sì fóc, nhưng có điều tất cả những gì phía dưới bảng 2 như chữ ký, thống kê ... bị xoá sạch. Mong các bác dùng tuyệt chiêu 1 lần nữa.
Vô cùng méc xi.

Sao lại phải cố ý thêm bớt dòng, trong khi bảng dữ liệu có sẵn mỗi bảng tối đa 12 dòng?
Ẩn các dòng trống đi được không?

Private Sub Worksheet_Change(ByVal Target As Range)
Dim nN, mM As Byte
Application.ScreenUpdating = False
If Not Intersect(Target, [E2]) Is Nothing Then
    Cells.Select
    Selection.EntireRow.Hidden = False
    If [F4] < 12 Then Rows([F4] + 9 & ":20").EntireRow.Hidden = True
    If [F5] < 12 Then Rows([F5] + 24 & ":35").EntireRow.Hidden = True
End If
[E2].Select
Application.ScreenUpdating = True
End Sub

 

[jlx2002-ls]

Méc xi các bác vô cùng nhiều,
Các bác đã làm đúng ý em y sì fóc, nhưng có điều tất cả những gì phía dưới bảng 2 như chữ ký, thống kê ... bị xoá sạch. Mong các bác dùng tuyệt chiêu 1 lần nữa.
Vô cùng méc xi.

OK, không có gì cả

Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
    Dim BienChay As Integer
    Dim xN1 As Integer, xN2 As Integer
    Dim KhoangCach1 As Integer, KhoangCach2 As Integer
    If [so1] > 1 Then
    xN1 = [so1]
    ElseIf [so1] <= 1 Then
    xN1 = 2
    End If
    If [so2] > 1 Then
    xN2 = [so2]
    ElseIf [so2] <= 1 Then
    xN2 = 2
    End If
    If Not Intersect(Target, Range("c2")) Is Nothing Then
     Application.ScreenUpdating = False
     Application.EnableEvents = False
        If xN1 >= 0 Then
           KhoangCach1 = Range("bang2").Row - Range("bang1").Row - 4
           If xN1 > KhoangCach1 Then
                For BienChay = 1 To xN1 - KhoangCach1
                    Rows(Range("bang1").Row + 2).Select
                    Selection.Insert Shift:=xlDown
                Next
            ElseIf xN1 < KhoangCach1 Then
                For BienChay = 1 To KhoangCach1 - xN1
                    Rows(Range("bang1").Row + xN1).Select
                    Selection.Delete Shift:=xlUp
                Next
            End If
         End If
        If xN2 >= 0 Then
           KhoangCach2 = Range("bang3").Row - Range("bang2").Row - 3
           If xN2 > KhoangCach2 Then
                For BienChay = 1 To xN2 - KhoangCach2
                    Rows(Range("bang2").Row + 2).Select
                    Selection.Insert Shift:=xlDown
                Next
            ElseIf xN2 < KhoangCach2 Then
                For BienChay = 1 To KhoangCach2 - xN2
                    Rows(Range("bang2").Row + xN2).Select
                    Selection.Delete Shift:=xlUp
                Next
            End If
         End If
      End If
    Range("c3").Select
    Application.EnableEvents = True
    Application.ScreenUpdating = True
End Sub

Xem file đính kèm

 

[sealand]

Nếu vậy thì lưu cái vùng chữ ký ấy lại rồi dán vào sau

Private Sub Worksheet_Change(ByVal Target As Range)
Dim i, Rg1 As Range, Rg2 As Range, tam
Application.ScreenUpdating = False
If Target.Address = "$E$2" Then
tam = Range("Ky").Resize(4, 6)
Set Rg1 = Columns(3).Find(what:="STT")
Set Rg2 = Columns(3).FindNext(after:=Rg1)
Rg2.Offset(2).Resize(30, 6).Delete
Rg2.Offset(1).Resize(, 6).Copy Rg2.Offset(1).Resize([F5], 6)
Rg2.Offset([F5] + 2).Resize(4, 6) = tam
Rg2.Offset([F5] + 2).Name = "Ky"
If Rg2.Row - Rg1.Row > 4 Then Rows(Rg1.Row + _
1 & ":" & Rg2.Row - 3).EntireRow.Delete
For i = 1 To [F4]
Rg1.Offset(1).EntireRow.Insert
Set Rg2 = Columns(3).FindNext(after:=Rg1)
Rg2.Offset(1).EntireRow.Copy Rg1.Offset(1, -2)
Next
End If
Set Rg1 = Nothing: Set Rg2 = Nothing
End Sub