Các cách thêm dòng mới vô 1 CSDL (cơ sở dữ liệu) đã sẵn

TQChanh

Member
Hội viên mới
Mình có dữ liệu như như bảng bên trái của hình;
Giờ muốn tái cấu trúc lại thành dữ liệu như bên fải của hình; Khi đó ta cần xài macro như sau:
PHP:
Option Explicit
Sub GPE_ThemDong()
 Dim Arr(), Dict As Object
 Dim J As Long, W As Long, Col As Byte
 Dim Tmp As String
 Set Dict = CreateObject("Scripting.Dictionary")
 With Sheets("Data")
  Arr = .Range(.[A2], .[D65000].End(3)).Value
  ReDim dArr(1 To 2 * UBound(Arr()), 1 To 4)
  For J = 1 To UBound(Arr())
  Tmp = Arr(J, 1)
  If Not Dict.Exists(Tmp) Then
  W = W + 1:  Dict.Add Tmp, W
  dArr(W, 1) = Tmp:  W = W + 1
  For Col = 2 To 4
  dArr(W, Col) = Arr(J, Col)
  Next Col
  Else
  W = W + 1
  For Col = 2 To 4
  dArr(W, Col) = Arr(J, Col)
  Next Col
  End If
  Next J
 End With
 [g2].Resize(W, 4).Value = dArr()
End Sub
 

Đính kèm

TQChanh

Member
Hội viên mới
Chào các anh chị, Tôi có file excel muốn thêm dòng trắng tự động giữa các số chứng từ cách nhau. Ví dụ từ A2: A6 là từ chứng từ 138 đến 142. Bây giờ ô A7 là: số chứng từ 149. Bây giờ tôi muốn giữa dòng 6 và 7, thêm 6 dòng trắng (149-142=7) thì không biết có được không. Tôi chỉ cần thêm dòng trắng thôi. Tương tự với số chứng từ tiếp theo.
PHP:
Option Explicit
Sub ThemDong()
 Dim J As Long, Rws As Long, Tmp As Byte, W As Long
 Dim Arr()
 Arr() = Range([A3], [A3].End(xlDown)).Value
 Rws = UBound(Arr())
 ReDim dArr(1 To 9 * Rws, 1 To 1) As String
 Do
  J = J + 1
  If J = UBound(Arr()) Then
  dArr(W + 1, 1) = Arr(J, 1):  Exit Do
  End If
  Tmp = Arr(J + 1, 1) - Arr(J, 1):  W = W + 1
  dArr(W, 1) = Arr(J, 1)
  If Tmp > 1 Then W = W + Tmp - 1
 Loop
 [A2].Resize(W + 1).Value = dArr()
End Sub
Các bạn có thể xem file ở: http://www.giaiphapexcel.com/forum/showthread.php?112005-Thêm-dòng-trắng-giữa-các-số-dòng-chứng-từ-cách-nhau-bằng-code-VBA&p=702881&posted=1#post702881
 

TQChanh

Member
Hội viên mới
Bỡi do nhìn vô thiết kế CSDL của file thấy mà ngộp, chắc vậy!
Mình thảo luận vấn đề sau:
Với trang 'Nhap Doanh Thu' (Tên quá dài; chỉ nên là NhapDT) sao bạn không đẩy dòng 11 hiện giờ (đang chứa công thức tổng) xuống dòng 999# nào đó; & cho ẩn hết các dòng không chứa dữ liệu trước 999# đó đi.
Khi đó nếu nhập vô ô nào đó của dòng trắng đầu tiên sau dòng cuối chứa dữ liệu thì hiện thêm 1 dòng trắng nữa chờ sẵn.
Khi đó macro sự kiện chỉ làm mỗi việc cho hiện dòng ẩn đầu tiên trong nhóm dòng đã ẩn lên thôi;
Còn nói về công thức, chỉ có mỗi một ở cột [Q:Q] thôi, fải không? chuyện này cũng dễ giải quyết mà!
 

TQChanh

Member
Hội viên mới
Em có bảng dữ liệu từ A8:N8 trở về dòng cuối
Cần được giúp 1macro để có thể thêm hay không thêm, thậm chí cần xóa dòng theo số liệu có trên cột [N] này
Cụ thể như sau:
1/ Nếu N8=0 thì chèn thêm 2 dòng bên dưới N8 sau đó sao chép dữ liệu trong ô từ D8:K8 xuống những dòng vừa chèn thêm (kiểu nhân bản)
2/ Nếu N8 =1 thì chèn thêm 1 dòng bên dưới N8 sau đó sao chép dữ liệu trong ô từ D8:K8 xuống những dòng vừa chèn thêm (kiểu nhân bản)
3/ Nếu N8=2 thì không chèn thêm dòng
4/ Nếu N8=3 thì xóa bỏ dòng N8
Áp dụng như vậy cho các dòng tiếp theo.
Macro thực hiện việc này có nội dung sau:
PHP:
Option Explicit
Sub ThemXoaDong()
 Dim Rws As Long, J As Long, Dg As Integer, Col As Byte, W As Long, Cot As Byte
 Dim Arr()
 Rws = [b8].CurrentRegion.Rows.Count
 J = Application.WorksheetFunction.Sum([N8].Resize(Rws))
 ReDim dArr(1 To Rws + J, 1 To 14)
 Arr() = [A8].Resize(Rws, 14).Value
 For J = 1 To UBound(Arr())
  If Arr(J, 1) = "" Then Exit For
  If Arr(J, 14) <> 3 Then
  W = W + 1
  For Col = 1 To 14
  dArr(W, Col) = Arr(J, Col)
  Next Col
  End If
  If Arr(J, 14) = 0 Then
  For Cot = 1 To 2
  W = W + 1
  For Col = 4 To 14
  dArr(W, Col) = Arr(J, Col)
  Next Col
  Next Cot
  ElseIf Arr(J, 14) = 1 Then
  W = W + 1
  For Col = 4 To 14
  dArr(W, Col) = Arr(J, Col)
  Next Col
  End If
 Next J
9 [A18].Resize(W, 14).Value = dArr()
End Sub
 

TQChanh

Member
Hội viên mới
Chào các anh chị,
Hiện tại công việc hằng ngày của em phải insert dòng khá nhiều và mất rất nhiều thời gian
Em cũng đã tìm trên google rất nhiều lần nhưng không có trường hợp nào tương tự của em
Bảng mô tả như bên dưới, đồng thời em đính kèm file mau, mong các anh chị giúp đỡ em nha
Em cảm ơn rất nhiều
A1 B1 C1 D1 ... O1 S1 T1 ... AN1
10.11...22 XYZ A B ... N 10 11 ... 22














Kết quả có được

A1 B1 C1 D1 ... O1 S1 T1 ... AN1
10 XYZ A B ... N 10 11 ... 22
11 XYZ A B ... N 10 11 ... 22
... XYZ A B ... N 10 11 ... 22
22 XYZ A B ... N 10 11 ... 22

Lời giải của thầy Ba Tê tại:
http://www.giaiphapexcel.com/forum/showthread.php?124030-Insert-dòng-đồng-thời-copy-nội-dung-của-dòng-phía-trên-theo-điều-kiện-của-SP


PHP:
 Option Explicit

Public Sub GPE()

Dim sArr(), I As Long, J As Long, K As Long, N As Long, Tmp

Dim dArr(1 To 10000, 1 To 29)

With Sheets("MM 1708")

  sArr = .Range("A4", .Range("A4").End(xlDown)).Resize(, 29).Value

End With

For I = 2 To UBound(sArr)

  Tmp = Split(sArr(I, 1), ".")

  For N = 0 To UBound(Tmp)

  K = K + 1:  dArr(K, 1) = Tmp(N)

  For J = 2 To 29

  dArr(K, J) = sArr(I, J)

  Next J

  Next N

Next I

With Sheets("GPE")

  .Range("A5").Resize(K, 29) = dArr

End With

End Sub
 

TQChanh

Member
Hội viên mới
Xin chào mọi người
Em đang có ý tưởng để làm file đổ tự động chi phí. Nhưng đang vướng mắc như sau:
Giờ có dữ liệu ở sheet"Data" em muốn có thông tin như ở sheet "KQua".
1 số hóa đơn sẽ cho ra số dòng = ( số hiện ở cột [line CP xuất hiện] + 2), chi tiết như file đính kèm em gửi ở:
http://www.giaiphapexcel.com/forum/showthread.php?124293-Thêm-dòng-có-điều-kiện&p=777462&posted=1#post777462

& bổ sung: http://www.giaiphapexcel.com/forum/showthread.php?124313-Thêm-số-dòng-có-điều-kiện&p=777875#post777875
 

romkut3

New Member
Hội viên mới
tình hình là em có 1 file đã viết sẵn, giời muốn thêm dòng có điều kiện so sánh 1 chứ...áp dụng bài BÀI VIID Find word then insert 2 rows nhưng k thực hiện được, nhờ anh chị giúp dùm trong sheet chỉnh sửa ạ,
 

Đính kèm

TQChanh

Member
Hội viên mới
Thêm dòng có điều kiện so sánh 1 sẽ là như thế nào?

Bạn cần nêu rõ thêm.
 

romkut3

New Member
Hội viên mới
Thêm dòng có điều kiện so sánh 1 sẽ là như thế nào?

Bạn cần nêu rõ thêm.
dạ ý em là thêm dòng có điều kiện... nếu nó có chứa dấu "+" thì sẻ thêm vào đó 2 hoặc 3 dòng tùy theo cấp dấu "+"
còn so sánh có nghĩa là khj nó đã tự chèn thêm 2 dòng thì 2 dòng đó sẻ điền thông tin vào các ô khác( trong file em có nêu rõ) tương ứng ở sheet Dulieu ạ
 

TQChanh

Member
Hội viên mới
Tách Dòng.JPG

PHP:
Const GPE As Long = 65500
Sub TáchḌng()
 ReDim Arr(1 To GPE, 1 To 2)
 Dim J As Long, W As Long, Num As Double, Rws As Long
 Dim TenHang As String

 [F7].Resize(65500, 2).Value = Arr()
 For J = 7 To [b7].End(xlDown).Row
    Num = Cells(J, "C").Value:              TenHang = Cells(J, "B").Value
    If Num <= 0 Then
        W = W + 1
        Arr(W, 1) = TenHang:                Arr(W, 2) = Num
    Else
        Do
            If Num - 1 >= 1 Then
                W = W + 1:                  Arr(W, 1) = TenHang
                Arr(W, 2) = 1:              Num = Num - 1
            Else             '*'
                W = W + 1:                  Arr(W, 1) = TenHang
                Arr(W, 2) = 1
                If Num > 1 Then
                    W = W + 1:              Arr(W, 1) = TenHang
                    Arr(W, 2) = Num - 1
                End If
                Exit Do
            End If
        Loop
    End If
 Next J
 If W Then
    [F7].Resize(W, 2).Value = Arr()
 End If
End Sub
 

TQChanh

Member
Hội viên mới
Thêm Dòng.JPG

Trên hình ta có bảng dữ liệu (fía trái);
Ở cột [Đầu] & [Cuối] có thể có 2 trường hợp sẩy ra với hiệu của chúng:
Nếu hiệu giữa [Cuối] - [Đầu] bé hơn hay bằng 1 thì ta không cần thêm dòng
Nếu ngược lại ta cần thêm những dòng sao cho hiệu này luôn bé hơn hay bằng 1 mà thôi:
Các bạn nhìn vô 2 mũi tên để rõ hơn yêu cầu thêm dòng. (Bảng bên fải là kết quả thêm dòng mong muốn)
Bảng kết quả thêm dòng sẽ được macro sau đây thực hiện mỹ mãn:
PHP:
Sub ThemCacDongSoLieuTheoHieu2Cot()
Dim J As Long, Rws As Long, W As Integer, SDg As Byte, Dm As Byte, Z As Integer, BD As Double, KT As Double
Dim Arr():                                      ReDim dArr(1 To 65500, 1 To 6)

Rws = [e1].CurrentRegion.Rows.Count - 1
Arr() = [A2].Resize(Rws, 7).Value
For J = 1 To UBound(Arr())
    If Arr(J, 1) = "" Then Exit For
    SDg = Arr(J, 5) - Arr(J, 4)
    If SDg > 1 Then
        BD = Arr(J, 4):                     KT = Arr(J, 5)
        For Z = 0 To SDg
            W = W + 1:                      dArr(W, 1) = W
            For Dm = 2 To 6
                If Dm < 4 Or Dm > 5 Then
                    dArr(W, Dm) = Arr(J, Dm)
                Else
                    dArr(W, 4) = BD
                    If BD + 1 < KT Then
                        dArr(W, 5) = BD + 1
                    Else
                        dArr(W, 5) = KT
                    End If
                End If
            Next Dm
            BD = BD + 1:                    If BD > KT Then Exit For
        Next Z
    Else
        W = W + 1:                          dArr(W, 1) = W
        For Dm = 2 To 6
            dArr(W, Dm) = Arr(J, Dm)
        Next Dm
    End If
Next J
[j2].Resize(W, 6).Value = dArr()
End Sub
 

TQChanh

Member
Hội viên mới
Có bảng dữ liệu ban đầu gồm 3 cột; Trong đó cột cuối có những dòng có chứa các con số;
Khi muốn thêm dòng bằng với các con số cho trước & những dòng thêm chỉ chứa ở cột A các giá trị đang ở cột 'B' của dòng chứa số (cần thêm dòng)

Dữ liệu ban đầu
Dữ liệu mong muốn
abzabz
ac2ac
2​
adyc
ae3c
afuady
agzae
3​
ah5e
aite
e
afu
agz
ah
5​
h
h
h
h
h
ait
'

PHP:
Sub ThemDongTheoSoLieuChoTruoc()
Dim WF As Object, Arr()
Dim J As Long, W As Long, Cot As Integer
Dim GPE As String

Set WF = Application.WorksheetFunction
With Sheet1
    Arr() = .[B6].CurrentRegion.Offset(1).Value
    W = WF.Sum(.[C6].Resize(UBound(Arr())))
    ReDim dArr(1 To UBound(Arr()) + 9 + W, 1 To 3)
    W = 0
    For J = 1 To UBound(Arr())
        W = W + 1:                      GPE = Arr(J, 2)
        For Cot = 1 To 3
            dArr(W, Cot) = Arr(J, Cot)
        Next Cot
        If IsNumeric(Arr(J, 3)) And Arr(J, 3) > 0 Then
            For Cot = 1 To Arr(J, 3)
                W = W + 1:              dArr(W, 1) = GPE
            Next Cot
        End If
    Next J
    .[F6].Resize(W, 3).Value = dArr()
End With
End Sub
 

CẨM NANG KẾ TOÁN TRƯỞNG


Liên hệ: 090.6969.247

KÊNH YOUTUBE DKT

Kỹ thuật giải trình thanh tra BHXH

Đăng ký kênh nhé cả nhà

SÁCH QUYẾT TOÁN THUẾ


Liên hệ: 090.6969.247

Top