[Xin giúp code VBA] Tìm kiếm dữ liệu và chèn thêm 1 dòng sang Sheet khác

Liên hệ QC
H

hauhn

Thành viên mới
Tham gia
12/5/09
Bài viết
11
Được thích
1
Mình là dân ngoại đạo, Xin các bác giúp đỡ viết hàm vba.
mình có bảng excel gồm 2 sheet "Nhap DL" và "CD Ga-Cong". trong bảng cao độ ga cống mình có tên ga và các cột đáy cống ra, đáy cống vào A, B, C. Mặc định sẽ có dữ liệu ở cột đáy cống ra, các cột kia có thể có có thể không. mình muốn dùng VBA để lọc nếu 1 ga nào đó có dữ liệu ở cột đáy cống ra A sẽ tìm ga đó tương ứng ở bảng nhập DL, thêm 1 dòng phía dưới với tên ga thêm ".A" vào. sau đó copy dữ liệu từ các cột TỌA ĐỘ X TỌA ĐỘ Y "CAO ĐỘ TỰ NHIÊN" "CAO ĐỘ TIM ĐƯỜNG " "CAO ĐỘ MẶT GA (MG)" xuống dòng đó. tương tự lặp lại với các cột đáy cống B, đáy cống C. các dòng chèn vào ngay bên dưới ga tương ứng ở bảng nhập DL.
mình gửi kèm file mẫu, Cảm ơn các bạn.
 

File đính kèm

  • file loc.xlsm
    180.5 KB · Đọc: 14
Sắp xếp theo thời gian sắp xếp theo bầu chọn
Nhattanktnn đã viết:
Chưa thấy dòng này đâu hết. Bạn nên đưa ra kết quả giả định rõ ràng nha
Nhấp chuột vào đây để mở rộng...
VD bên bảng Nhap DL mình đang thêm bằng thủ công các ga G07.A; G07.B bên dưới ga G07. Nhưng không phải ga nào cũng có ga phụ .A , .B như vậy mà chỉ ga nào có dữ liệu bên cột đáy cống vào A, đáy cống vào B..... mới có dữ liệu tương ứng và tự động thêm vào bảng Nhap DL bên dưới ga tương ứng. mình muốn tự động lọc và thêm được bằng vba bạn ạ1.JPG2.JPG
 
Upvote 0
hauhn đã viết:
VD bên bảng Nhap DL mình đang thêm bằng thủ công các ga G07.A; G07.B bên dưới ga G07. Nhưng không phải ga nào cũng có ga phụ .A , .B như vậy mà chỉ ga nào có dữ liệu bên cột đáy cống vào A, đáy cống vào B..... mới có dữ liệu tương ứng và tự động thêm vào bảng Nhap DL bên dưới ga tương ứng. mình muốn tự động lọc và thêm được bằng vba bạn ạView attachment 253956View attachment 253957
Nhấp chuột vào đây để mở rộng...
Tôi vẫn đang mơ hồ chưa thực sự hiểu:
1/ Câu đơn giản nhất, đó là code cho sheet nào? Tôi đang nghĩ code cho sheet "Nhap DL" nhưng mà thấy nếu thêm mới dòng thì chả biết tọa độ lấy đâu ra
2/ Câu này:
hauhn đã viết:
không phải ga nào cũng có ga phụ .A , .B như vậy mà chỉ ga nào có dữ liệu bên cột đáy cống vào A, đáy cống vào B..... mới có dữ liệu tương ứng
Nhấp chuột vào đây để mở rộng...
Vậy những tên nút dưới đây sao lại có .A .B
1612448268087.png
3/ Bạn nên làm thử minh họa 1 vài dòng kết quả để tôi và những người khác vào xem hiểu rõ được không
 
Upvote 0
Nhattanktnn đã viết:
Tôi vẫn đang mơ hồ chưa thực sự hiểu:
1/ Câu đơn giản nhất, đó là code cho sheet nào? Tôi đang nghĩ code cho sheet "Nhap DL" nhưng mà thấy nếu thêm mới dòng thì chả biết tọa độ lấy đâu ra
2/ Câu này:

Vậy những tên nút dưới đây sao lại có .A .B
View attachment 253959
3/ Bạn nên làm thử minh họa 1 vài dòng kết quả để tôi và những người khác vào xem hiểu rõ được không
Nhấp chuột vào đây để mở rộng...
Mình gửi lại file ban đầu và file kết quả mong muốn. bạn xem giúp mình nhé.
Ý tưởng là lấy dữ liệu bên file CD Ga-Cong dựa vào kết quả cột Đáy cống A, B, C có dữ liệu hay không để chèn thêm hàng vào bảng nhập DL. Các thông tin trong bản CD Ga-Cống mình có sẵn bạn ạ. các tọa độ mình lấy từ Autocad. Nếu bảng CD Ga_Cống có thay đổi thì bảng Nhap _DL sẽ xóa hết những dòng ga phụ đi và lọc lại từ đầu như kiểu nạp lại dữ liệu cho bảng Nhập_DL bạn ạ
DL Ban Dau.JPGKet Qua.JPG
 

File đính kèm

  • File ban đầu.xlsm
    28.6 KB · Đọc: 9
  • File kết quả.xlsm
    29.5 KB · Đọc: 10
Upvote 0
hauhn đã viết:
Mình gửi lại file ban đầu và file kết quả mong muốn. bạn xem giúp mình nhé.
Ý tưởng là lấy dữ liệu bên file CD Ga-Cong dựa vào kết quả cột Đáy cống A, B, C có dữ liệu hay không để chèn thêm hàng vào bảng nhập DL. Các thông tin trong bản CD Ga-Cống mình có sẵn bạn ạ. các tọa độ mình lấy từ Autocad. Nếu bảng CD Ga_Cống có thay đổi thì bảng Nhap _DL sẽ xóa hết những dòng ga phụ đi và lọc lại từ đầu như kiểu nạp lại dữ liệu cho bảng Nhập_DL bạn ạ
View attachment 253962View attachment 253963
Nhấp chuột vào đây để mở rộng...
Chạy code
Mã: 
Sub ABC()
  Dim sArr(), Arr(), S, Res() As String, Res2(), Dic As Object
  Dim sRow, sR&, i&, j&, k&
 
  Set Dic = CreateObject("scripting.dictionary")
  Arr = Array("", ".A", ".B", ".C")
  With Sheet3
    sArr = .Range("B1:G" & .Range("B" & Rows.Count).End(xlUp).Row).Value
  End With
 
  sRow = UBound(sArr)
  For i = 2 To sRow
    For j = 4 To 6
      If sArr(i, j) <> Empty Then
        sR = sR + 1
        Dic.Item(sArr(i, 1)) = Dic.Item(sArr(i, 1)) & "," & Arr(j - 3)
      End If
    Next j
  Next i
 
  With Sheet1
    sArr = .Range("C2:I" & .Range("C" & Rows.Count).End(xlUp).Row).Value
  End With
  sRow = UBound(sArr)
  ReDim Res(1 To sRow + sR, 1 To 3)
  ReDim Res2(1 To sRow + sR, 1 To 4)
  For i = 1 To sRow
    Call AddRes(sArr, Res, Res2, i, k, 7)
    If Dic.exists(sArr(i, 1)) Then
      S = Split(Dic.Item(sArr(i, 1)), ",")
      For j = 1 To UBound(S)
        Call AddRes(sArr, Res, Res2, i, k, 5)
        Res(k, 1) = Res(k, 1) & S(j)
      Next j
    End If
  Next i
  With Sheet1
    .Range("C2").Resize(k, 3) = Res
    .Range("F2").Resize(k, 4) = Res2
  End With
End Sub

Private Sub AddRes(ByRef sArr, ByRef Res, ByRef Res2, ByRef i, ByRef k, ByVal sCol&)
  Dim j&
  k = k + 1
  For j = 1 To sCol
    If j < 4 Then
      Res(k, j) = sArr(i, j)
    Else
      Res2(k, j - 3) = sArr(i, j)
    End If
  Next j
End Sub
 
Upvote 0
HieuCD đã viết:
Chạy code
Mã: 
Sub ABC()
  Dim sArr(), Arr(), S, Res() As String, Res2(), Dic As Object
  Dim sRow, sR&, i&, j&, k&

  Set Dic = CreateObject("scripting.dictionary")
  Arr = Array("", ".A", ".B", ".C")
  With Sheet3
    sArr = .Range("B1:G" & .Range("B" & Rows.Count).End(xlUp).Row).Value
  End With

  sRow = UBound(sArr)
  For i = 2 To sRow
    For j = 4 To 6
      If sArr(i, j) <> Empty Then
        sR = sR + 1
        Dic.Item(sArr(i, 1)) = Dic.Item(sArr(i, 1)) & "," & Arr(j - 3)
      End If
    Next j
  Next i

  With Sheet1
    sArr = .Range("C2:I" & .Range("C" & Rows.Count).End(xlUp).Row).Value
  End With
  sRow = UBound(sArr)
  ReDim Res(1 To sRow + sR, 1 To 3)
  ReDim Res2(1 To sRow + sR, 1 To 4)
  For i = 1 To sRow
    Call AddRes(sArr, Res, Res2, i, k, 7)
    If Dic.exists(sArr(i, 1)) Then
      S = Split(Dic.Item(sArr(i, 1)), ",")
      For j = 1 To UBound(S)
        Call AddRes(sArr, Res, Res2, i, k, 5)
        Res(k, 1) = Res(k, 1) & S(j)
      Next j
    End If
  Next i
  With Sheet1
    .Range("C2").Resize(k, 3) = Res
    .Range("F2").Resize(k, 4) = Res2
  End With
End Sub

Private Sub AddRes(ByRef sArr, ByRef Res, ByRef Res2, ByRef i, ByRef k, ByVal sCol&)
  Dim j&
  k = k + 1
  For j = 1 To sCol
    If j < 4 Then
      Res(k, j) = sArr(i, j)
    Else
      Res2(k, j - 3) = sArr(i, j)
    End If
  Next j
End Sub
Nhấp chuột vào đây để mở rộng...
cảm ơn bạn, code chạy Ok rồi. bạn sửa thêm giúp mình 1 chút nhé. khi mình thay đổi dữ liệu bên bảng CD Ga-Cống rồi chạy lại thì ko xóa dữ liệu cũ. bạn lọc giúp mình dữ liệu cũ xóa hết các dòng đấy giúp mình.
Ý là trước khi chạy lệnh thì kiểm tra toàn bộ cột xem có ga dạng .A, .B, .C không. nếu có thì xóa hết đi rồi mới chạy code ý bạn1.JPG
 
Upvote 0
hauhn đã viết:
cảm ơn bạn, code chạy Ok rồi. bạn sửa thêm giúp mình 1 chút nhé. khi mình thay đổi dữ liệu bên bảng CD Ga-Cống rồi chạy lại thì ko xóa dữ liệu cũ. bạn lọc giúp mình dữ liệu cũ xóa hết các dòng đấy giúp mình.
Ý là trước khi chạy lệnh thì kiểm tra toàn bộ cột xem có ga dạng .A, .B, .C không. nếu có thì xóa hết đi rồi mới chạy code ý bạnView attachment 253977
Nhấp chuột vào đây để mở rộng...
Chỉnh lại
Mã: 
Sub ABC()
  Dim sArr(), Arr(), S, Res() As String, Res2(), Dic As Object
  Dim sRow, sR&, i&, j&, k&, iKey$
  Const oldGa$ = ".A.B.C."
 
  Set Dic = CreateObject("scripting.dictionary")
  Arr = Array("", ".A", ".B", ".C")
  With Sheet3
    sArr = .Range("B1:G" & .Range("B" & Rows.Count).End(xlUp).Row).Value
  End With
 
  sRow = UBound(sArr)
  For i = 2 To sRow
    For j = 4 To 6
      If sArr(i, j) <> Empty Then
        sR = sR + 1
        Dic.Item(sArr(i, 1)) = Dic.Item(sArr(i, 1)) & "," & Arr(j - 3)
      End If
    Next j
  Next i
 
  With Sheet1
    sArr = .Range("C2:I" & .Range("C" & Rows.Count).End(xlUp).Row).Value
  End With
  sRow = UBound(sArr)
  ReDim Res(1 To sRow + sR, 1 To 3)
  ReDim Res2(1 To sRow + sR, 1 To 4)
  For i = 1 To sRow
    iKey = sArr(i, 1)
    If InStr(1, oldGa, Right(iKey, 2) & ".") = 0 Then
      Call AddRes(sArr, Res, Res2, i, k, 7)
      If Dic.exists(sArr(i, 1)) Then
        S = Split(Dic.Item(iKey), ",")
        For j = 1 To UBound(S)
          Call AddRes(sArr, Res, Res2, i, k, 5)
          Res(k, 1) = Res(k, 1) & S(j)
        Next j
      End If
    End If
  Next i
  With Sheet1
    i = .Range("C" & Rows.Count).End(xlUp).Row
    If i > k + 1 Then .Range("C2").Offset(k).Resize(i - k - 1, 7).ClearContents
    .Range("C2").Resize(k, 3) = Res
    .Range("F2").Resize(k, 4) = Res2
  End With
End Sub

Private Sub AddRes(ByRef sArr, ByRef Res, ByRef Res2, ByRef i, ByRef k, ByVal sCol&)
  Dim j&
  k = k + 1
  For j = 1 To sCol
    If j < 4 Then
      Res(k, j) = sArr(i, j)
    Else
      Res2(k, j - 3) = sArr(i, j)
    End If
  Next j
End Sub
 
Upvote 0
HieuCD đã viết:
Chỉnh lại
Mã: 
Sub ABC()
  Dim sArr(), Arr(), S, Res() As String, Res2(), Dic As Object
  Dim sRow, sR&, i&, j&, k&, iKey$
  Const oldGa$ = ".A.B.C."

  Set Dic = CreateObject("scripting.dictionary")
  Arr = Array("", ".A", ".B", ".C")
  With Sheet3
    sArr = .Range("B1:G" & .Range("B" & Rows.Count).End(xlUp).Row).Value
  End With

  sRow = UBound(sArr)
  For i = 2 To sRow
    For j = 4 To 6
      If sArr(i, j) <> Empty Then
        sR = sR + 1
        Dic.Item(sArr(i, 1)) = Dic.Item(sArr(i, 1)) & "," & Arr(j - 3)
      End If
    Next j
  Next i

  With Sheet1
    sArr = .Range("C2:I" & .Range("C" & Rows.Count).End(xlUp).Row).Value
  End With
  sRow = UBound(sArr)
  ReDim Res(1 To sRow + sR, 1 To 3)
  ReDim Res2(1 To sRow + sR, 1 To 4)
  For i = 1 To sRow
    iKey = sArr(i, 1)
    If InStr(1, oldGa, Right(iKey, 2) & ".") = 0 Then
      Call AddRes(sArr, Res, Res2, i, k, 7)
      If Dic.exists(sArr(i, 1)) Then
        S = Split(Dic.Item(iKey), ",")
        For j = 1 To UBound(S)
          Call AddRes(sArr, Res, Res2, i, k, 5)
          Res(k, 1) = Res(k, 1) & S(j)
        Next j
      End If
    End If
  Next i
  With Sheet1
    i = .Range("C" & Rows.Count).End(xlUp).Row
    If i > k + 1 Then .Range("C2").Offset(k).Resize(i - k - 1, 7).ClearContents
    .Range("C2").Resize(k, 3) = Res
    .Range("F2").Resize(k, 4) = Res2
  End With
End Sub

Private Sub AddRes(ByRef sArr, ByRef Res, ByRef Res2, ByRef i, ByRef k, ByVal sCol&)
  Dim j&
  k = k + 1
  For j = 1 To sCol
    If j < 4 Then
      Res(k, j) = sArr(i, j)
    Else
      Res2(k, j - 3) = sArr(i, j)
    End If
  Next j
End Sub
Nhấp chuột vào đây để mở rộng...
Tuyệt vời. Code chạy đúng ý mình muốn. Cảm ơn bạn rất nhiều.
Mình hỏi thêm 1 chút : nếu trong bảng Nhập DL mình chèn thêm các cột mới và muốn copy nó xuống cùng thì sửa ở đâu trong code VB này. số cột này mình chưa xác định trước, chỉ trừ 2 cột cuối ko copy xuống thôi. Cảm ơn bạn
 
Upvote 0
hauhn đã viết:
Tuyệt vời. Code chạy đúng ý mình muốn. Cảm ơn bạn rất nhiều.
Mình hỏi thêm 1 chút : nếu trong bảng Nhập DL mình chèn thêm các cột mới và muốn copy nó xuống cùng thì sửa ở đâu trong code VB này. số cột này mình chưa xác định trước, chỉ trừ 2 cột cuối ko copy xuống thôi. Cảm ơn bạn
Nhấp chuột vào đây để mở rộng...
Chỉnh nhiều lệnh, chỉnh cái gì còn tùy các cột nằm ở vị trí nào và ...
 
Upvote 0
HieuCD đã viết:
Chỉnh nhiều lệnh, chỉnh cái gì còn tùy các cột nằm ở vị trí nào và ...
Nhấp chuột vào đây để mở rộng...
Bạn giúp mình sửa 1 xíu nữa nhé. ở file ban đầu mình có các cột từ D đến H là các cột nhập số liệu bằng tay, các cột I đến M chạy bằng công thức. mình muốn nó mang xuống .A, .B, .C theo công thức chung luôn.
Bên bảng CD Ga-Cống nếu dữ liệu cột Đáy cống vào A (cột E) có giá trị bằng cột đáy cống ra (cột D) thì không chèn thêm ga .A bên bảng Nhập DL nữa. tương tự so sánh giá trị ở cột F, cột G với cột D. Nếu bằng nhau thì không thêm nữa.
mình gửi lại file ban đầu, bạn xem giúp mình nhé. Cảm ơn bạn nhiều.

1.JPG2.JPG
 

File đính kèm

  • File ban đầu.xlsm
    411.8 KB · Đọc: 6
Upvote 0
hauhn đã viết:
Bạn giúp mình sửa 1 xíu nữa nhé. ở file ban đầu mình có các cột từ D đến H là các cột nhập số liệu bằng tay, các cột I đến M chạy bằng công thức. mình muốn nó mang xuống .A, .B, .C theo công thức chung luôn.
Bên bảng CD Ga-Cống nếu dữ liệu cột Đáy cống vào A (cột E) có giá trị bằng cột đáy cống ra (cột D) thì không chèn thêm ga .A bên bảng Nhập DL nữa. tương tự so sánh giá trị ở cột F, cột G với cột D. Nếu bằng nhau thì không thêm nữa.
mình gửi lại file ban đầu, bạn xem giúp mình nhé. Cảm ơn bạn nhiều.
Nhấp chuột vào đây để mở rộng...
Kết quả như thế nào? tạo thêm 1 sheet ví dụ kết quả
 
Upvote 0
HieuCD đã viết:
Kết quả như thế nào? tạo thêm 1 sheet ví dụ kết quả
Nhấp chuột vào đây để mở rộng...
VD như này bạn xem giúp mình. thanks bạn
Bài đã được tự động gộp:

Maika8008 đã viết:
HieuCD cũng mướt mồ hôi với "dân ngoại đạo" luôn ấy chứ --=0 bởi: tuyệt vời luôn nhưng cho mình hỏi thêm tí nữa @!>><
Nhấp chuột vào đây để mở rộng...
bài toán này khá rắc rối và mất nhiều thời gian với mình nếu làm thủ công. còn dễ sai nữa. ko biết phải hỏi bạn ạ :D :D
 

File đính kèm

  • File ban đầu.xlsm
    38.6 KB · Đọc: 7
  • File kết quả.xlsm
    40.6 KB · Đọc: 8
Upvote 0
hauhn đã viết:
VD như này bạn xem giúp mình. thanks bạn
Bài đã được tự động gộp:


bài toán này khá rắc rối và mất nhiều thời gian với mình nếu làm thủ công. còn dễ sai nữa. ko biết phải hỏi bạn ạ :D :D
Nhấp chuột vào đây để mở rộng...
Ví dụ nầy đâu giống ví dụ trước, đưa dữ liệu lên phải chuẩn
Mã: 
Sub ABC()
  Dim sArr(), Arr(), S, Res() As String, Res2(), Dic As Object
  Dim sRow, sR&, i&, j&, k&, iKey$, CaoDo#
  Const oldGa$ = ".A.B.C."
 
  Set Dic = CreateObject("scripting.dictionary")
  Arr = Array("", ".A", ".B", ".C")
  With Sheet3
    sArr = .Range("B1:G" & .Range("B" & Rows.Count).End(xlUp).Row).Value
  End With
 
  sRow = UBound(sArr)
  For i = 2 To sRow
    iKey = sArr(i, 1)
    CaoDo = sArr(i, 3)
    For j = 4 To 6
      If sArr(i, j) <> Empty Then
        If CaoDo <> sArr(i, j) Then
          sR = sR + 1
          Dic.Item(iKey) = Dic.Item(iKey) & "," & Arr(j - 3)
        End If
      End If
    Next j
  Next i
 
  With Sheet1
    sArr = .Range("B2:H" & .Range("C" & Rows.Count).End(xlUp).Row).Value
  End With
  sRow = UBound(sArr)
  ReDim Res(1 To sRow + sR, 1 To 4)
  ReDim Res2(1 To sRow + sR, 1 To 3)
  For i = 1 To sRow
    iKey = sArr(i, 2)
    If InStr(1, oldGa, Right(iKey, 2) & ".") = 0 Then
      Call AddRes(sArr, Res, Res2, i, k)
      If Dic.exists(iKey) Then
        S = Split(Dic.Item(iKey), ",")
        For j = 1 To UBound(S)
          Call AddRes(sArr, Res, Res2, i, k)
          Res(k, 2) = Res(k, 2) & S(j)
        Next j
      End If
    End If
  Next i
  With Sheet1
    Application.ScreenUpdating = False
    i = .Range("C" & Rows.Count).End(xlUp).Row
    If i > k + 1 Then .Range("B3").Offset(k).Resize(i - k - 1, 12).Clear
    .Range("B2").Resize(k, 4) = Res
    .Range("F2").Resize(k, 3) = Res2
    .Range("I2:M2").Copy .Range("I3:M3").Resize(k - 1)
    .Range("B2:H2").Copy
    .Range("B3:H3").Resize(k - 1).PasteSpecial Paste:=xlPasteFormats
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
  End With
End Sub

Private Sub AddRes(ByRef sArr, ByRef Res, ByRef Res2, ByRef i, ByRef k)
  Dim j&
  k = k + 1
  For j = 1 To 7
    If j < 5 Then
      Res(k, j) = sArr(i, j)
    Else
      Res2(k, j - 4) = sArr(i, j)
    End If
  Next j
End Sub
 
Upvote 0
HieuCD đã viết:
Ví dụ nầy đâu giống ví dụ trước, đưa dữ liệu lên phải chuẩn
Mã: 
Sub ABC()
  Dim sArr(), Arr(), S, Res() As String, Res2(), Dic As Object
  Dim sRow, sR&, i&, j&, k&, iKey$, CaoDo#
  Const oldGa$ = ".A.B.C."

  Set Dic = CreateObject("scripting.dictionary")
  Arr = Array("", ".A", ".B", ".C")
  With Sheet3
    sArr = .Range("B1:G" & .Range("B" & Rows.Count).End(xlUp).Row).Value
  End With

  sRow = UBound(sArr)
  For i = 2 To sRow
    iKey = sArr(i, 1)
    CaoDo = sArr(i, 3)
    For j = 4 To 6
      If sArr(i, j) <> Empty Then
        If CaoDo <> sArr(i, j) Then
          sR = sR + 1
          Dic.Item(iKey) = Dic.Item(iKey) & "," & Arr(j - 3)
        End If
      End If
    Next j
  Next i

  With Sheet1
    sArr = .Range("B2:H" & .Range("C" & Rows.Count).End(xlUp).Row).Value
  End With
  sRow = UBound(sArr)
  ReDim Res(1 To sRow + sR, 1 To 4)
  ReDim Res2(1 To sRow + sR, 1 To 3)
  For i = 1 To sRow
    iKey = sArr(i, 2)
    If InStr(1, oldGa, Right(iKey, 2) & ".") = 0 Then
      Call AddRes(sArr, Res, Res2, i, k)
      If Dic.exists(iKey) Then
        S = Split(Dic.Item(iKey), ",")
        For j = 1 To UBound(S)
          Call AddRes(sArr, Res, Res2, i, k)
          Res(k, 2) = Res(k, 2) & S(j)
        Next j
      End If
    End If
  Next i
  With Sheet1
    Application.ScreenUpdating = False
    i = .Range("C" & Rows.Count).End(xlUp).Row
    If i > k + 1 Then .Range("B3").Offset(k).Resize(i - k - 1, 12).Clear
    .Range("B2").Resize(k, 4) = Res
    .Range("F2").Resize(k, 3) = Res2
    .Range("I2:M2").Copy .Range("I3:M3").Resize(k - 1)
    .Range("B2:H2").Copy
    .Range("B3:H3").Resize(k - 1).PasteSpecial Paste:=xlPasteFormats
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
  End With
End Sub

Private Sub AddRes(ByRef sArr, ByRef Res, ByRef Res2, ByRef i, ByRef k)
  Dim j&
  k = k + 1
  For j = 1 To 7
    If j < 5 Then
      Res(k, j) = sArr(i, j)
    Else
      Res2(k, j - 4) = sArr(i, j)
    End If
  Next j
End Sub
Nhấp chuột vào đây để mở rộng...
cảm ơn bạn đã nhiệt tình code giúp mình, chuẩn code mình mong muốn rồi ><></><></><></><></
 
Upvote 0
Upvote 0
huonglien1901 đã viết:
Đoạn này có ý nghĩa gì Anh?
Nhấp chuột vào đây để mở rộng...
Sub AddRes là Sub phụ, gán kết quả vào mảng kết quả, có thể gán trực tiếp các lệnh "k = k + 1 For j = 1 To 7 If j < 5 Then Res(k, j) = sArr(i, j) Else Res2(k, j - 4) = sArr(i, j) End If Next j " thay thế cho lệnh gọi Sub AddRes "Call AddRes(sArr, Res, Res2, i, k)" trong Sub ABC, nhưng code sẽ dài hơn
 
Upvote 0
Bạn phải đăng nhập hoặc đăng ký để trả lời bài viết tại đây.
Web KT

Bài viết mới nhất

ongke0711
  • Question
Tải hóa đơn điện tử (https://hoadondientu.gdt.gov.vn/) Excel Vba
    • Thích
    • Yêu thích
11 12 13
Trả lời
246
Đọc
13K
trannguyen197
T
Tuấn Bụng Bự
  • Question
Tìm Bộ 8 số xuất hiện nhiều nhất trong random( 1 - 80)
2
Trả lời
28
Đọc
599
Tuấn Bụng Bự
Tuấn Bụng Bự
C
Chia sẻ: Kết quả xổ số Keno
    • Cười
    • Thích
Trả lời
9
Đọc
234
ptm0412
ptm0412
P
Tổng hợp dữ liệu từ các sheet theo chọn lọc
Trả lời
14
Đọc
266
ptm0412
ptm0412
B
Định dạng condition formatting, đếm hỗn hợp dữ liệu merge và không merge
Trả lời
7
Đọc
116
Hoàng Tuấn 868
H
T
Tối ưu hóa hàm lấy dữ liệu từ bảng Tổng sang bảng chi tiết
Trả lời
7
Đọc
210
Hoàng Tuấn 868
H
nguyenphuochien166
Cách Vlookup hoặc cách lấy thông tin dữ liệu có dấu mũ lũy thừa?
    • Cười
Trả lời
6
Đọc
106
tigertiger
tigertiger
T
Không đếm dữ liệu rỗng trong PivotTable
Trả lời
8
Đọc
1K
hoangtuaotrang_hp_vn
H
B
Lọc dữ liệu trùng, đếm số lần, tự tô màu theo điều kiện.
Trả lời
3
Đọc
114
batista911
B
C
Công thức tự nhập liệu số lượng nhập khi bị âm
Trả lời
1
Đọc
92
hoangtuaotrang_hp_vn
H
kimtanmap
  • Question
Nhờ viết code VBA Macro lập lại.
Trả lời
5
Đọc
155
kimtanmap
kimtanmap
dung09031989
Xin giúp công thức tô màu các ô phía sau khi kế hoạch đặt hàng thiếu so với tồn kho.?
Trả lời
1
Đọc
77
hoangtuaotrang_hp_vn
H
huynhnhu1234
Tìm giá vé máy bay một chiều và khứ hồi
Trả lời
0
Đọc
47
huynhnhu1234
huynhnhu1234
V
[Nhờ giúp đỡ] Cách tìm thời gian bị trùng trong excel ở nhiều thời gian khác nhau
Trả lời
7
Đọc
127
tranvansau278
T
N
Hàm tìm giá trị theo giờ vào - ra
Trả lời
6
Đọc
119
Nguyễn Linh hn94
N
zarra
Cần giúp tạo form in mã vạch cho vật tư theo SL cụ thể.
Trả lời
4
Đọc
164
zarra
zarra
Nguyễn Duy Tuân
  • Question
Chia sẻ ControlForOffice - Bộ công cụ điều khiển Office/Excel
    • Thích
6 7 8
Trả lời
148
Đọc
95K
leminhksvl
L
HeSanbi
  • Question
Lỗi VBA: Cài đặt thông số ForceVBALoadFromSource trong Registry để VBA biên dịch không bị lỗi
    • Cảm ơn
    • Thích
Trả lời
5
Đọc
296
anhdepjai
A
H
Hàm đếm số ngày thứ bảy và chủ nhật trong một khoảng thời gian
Trả lời
17
Đọc
20K
DeTong
D
D
  • Question
Xin cách sắp xếp dữ liệu theo thứ tự không làm hỏng link
Trả lời
7
Đọc
306
cantl
C
Xem thêm…

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

Back
Top Bottom