Các câu hỏi về mảng trong VBA (Array) (1 người xem)

  • Thread starter Thread starter viehoai
  • Ngày gửi Ngày gửi
Liên hệ QC

Người dùng đang xem chủ đề này

Đang trực tuyến: 1 (Thành viên: 0, Khách: 1)
viehoai

viehoai

Thành viên gắn bó
Tham gia
22/5/09
Bài viết
2,599
Được thích
2,908
Xin các anh chị giúp đỡ Code Gán các giá trị của một Range là các phần tử của Mãng
Ví dụ: Tôi có các giá trị của Range("A1:A10"). Tôi muốn viết code để gán giá trị của các cells từ A1:A10 là các phần tử của Mãng Arr chẳn hạn.
Xin cảm ơn các anh chị
 
Sắp xếp theo thời gian sắp xếp theo bầu chọn
tam888 đã viết:
Đề nghị OanhTho phải đọc lại VBA từ Cơ bản
Tôi cảm thấy bạn học từ diễn đàn này lung tung quá - nói khác là học từ giữa ra hay cao xuống thì phải --- Nếu không phải thì bỏ qua, coi như tôi chưa viết.

So ở đây là tham số - bạn phải đọc code của họ thì sẽ hiểu so là gì --> so chính là thứ tự cột xét trùng (với code gốc bạn tham chiếu từ website của tây nhé) -- các cột sửa lại chỉnh lý sau thì tương tự, chỉ riêng với dk=2 thì lúc này so lại là thứ tự dòng (ở đây =1 luôn, vì họ chỉ xét mảng có một dòng A#:Q#)
Nhấp chuột vào đây để mở rộng...
Em cũng học theo kiểu của Bạn ý. Hôm trước có Anh nói là học theo kiểu "Tụt từ ngọn xuống gốc" đấy ạ
 
Upvote 0
Nguyễn Hoàng Oanh Thơ đã viết:
Xin chào snow25,
Bạn có thể giải thích thêm tham số Optional ByVal so = 1, trong:

Có tác dụng gì thế ạ?
If Not .exists(MyArray(i, so)) Then

OT thử thay thẳng số 1 vào:
If Not .exists(MyArray(i, 1)) Then
và sửa thành:

Thì code không có lỗi gì.
Như vậy cái "Optional ByVal so=1" dùng để lựa chọn trong trường hợp đặc biệt nào vậy ạ?
Nhấp chuột vào đây để mở rộng...
Cái đấy là chiều thứ 2 của mảng đó.Bỏ đi thay bằng 1 cũng không sao thì nó luôn chọn cột 1.:D
 
Upvote 0
PacificPR đã viết:
Em cũng học theo kiểu của Bạn ý. Hôm trước có Anh nói là học theo kiểu "Tụt từ ngọn xuống gốc" đấy ạ
Nhấp chuột vào đây để mở rộng...
Học kiểu đó , cảm giác nhanh có ích
nhưng động vào code bài khác khác kiểu đã biết, là dễ tẩu hỏa
Tuy thế cũng có nhiều người có đầu óc nhanh nhạy và thích ứng tốt - và thành công
 
Upvote 0
tam888 đã viết:
Đề nghị OanhTho phải đọc lại VBA từ Cơ bản
Tôi cảm thấy bạn học từ diễn đàn này lung tung quá - nói khác là học từ giữa ra hay cao xuống thì phải --- Nếu không phải thì bỏ qua, coi như tôi chưa viết.

So ở đây là tham số - bạn phải đọc code của họ thì sẽ hiểu so là gì --> so chính là thứ tự cột xét trùng (với code gốc bạn tham chiếu từ website của tây nhé) -- các codes sửa lại chỉnh lý sau thì tương tự, chỉ riêng với dk=2 thì lúc này so lại là thứ tự dòng (ở đây =1 luôn, vì họ chỉ xét mảng có một dòng A#:Q#)
Nên có thể người ta thích cột xét trùng là cột khác
Lưu ý hàm tẩy (remove ...:D ) trùng RemoveDupesDict ở đây chỉ xét 1 cột trùng của bảng MyArray
Nhấp chuột vào đây để mở rộng...


Xin chào tam888,
Cảm ơn bạn đã quan tâm và góp ý ạ.
Thực ra cách đây 2 tháng OT cũng cày code ác lắm ấy chứ, nhưng sau đó lại học thêm tiếng Nhật xen lẫn nên quên quên nhớ nhớ.
Xong mới đây lại dính vụ bọn trẻ thi học kỳ I nên OT phải kèm tụi nhỏ và 1 thời gian ngắn code cũng quên hết sạch. T_T
Dạ, đúng OT hay tìm hiểu những cái áp dụng cho công việc của OT không tìm hiểu bài bản từ đầu nên mới nông nỗi này.
OT vẫn hi vọng sau này sẽ có thêm nhiều thời gian rảnh để cày ạ :)
 
Upvote 0
@Nguyễn Hoàng Oanh Thơ
Code dưới của tôi nâng cấp lại code của @snow25, tăng thêm chút khả năng hữu dụng của Hàm

Sử dụng: Nằm ở sub Test
Diễn giải:
Hàm RemoveDupesArray2D sẽ trả lại kết quả của một mảng phụ thuộc tham số nhập vào:
1. DataArr - Nhập mảng
2. isRow - Lọc theo hàng (True) / cột (False)
3. NumRC - Thứ tự Cột hoặc hàng để lọc dữ liệu trùng
4. isTrans - Chuyển đổi mảng từ dọc sang ngang hoặc ngang sang dọc ( True/ False)
5. CellsResult - Nhập vào một Cells . Hàm sẽ trả kết quả tại Cells này

PHP: 
Sub Test_RemoveDupesArray2D()
  Sheet1.Range("A12:AH100").ClearContents
  Dim Arr: Arr = Sheet1.Range("A1:Q2").Value
    Call RemoveDupesArray2D(Arr, NumRC:=2, isRow:=False, _
                          isTrans:=False, CellsResult:=Sheet1.Range("A4"))
      
    Call RemoveDupesArray2D(Arr, NumRC:=2, isRow:=False, _
                          isTrans:=True, CellsResult:=Sheet1.Range("S4"))

    Call RemoveDupesArray2D(Arr, NumRC:=1, isRow:=True, _
                          isTrans:=False, CellsResult:=Sheet1.Range("A22"))
                          
    Call RemoveDupesArray2D(Arr, NumRC:=1, isRow:=True, _
                          isTrans:=True, CellsResult:=Sheet1.Range("S22"))
    
End Sub
  Function RemoveDupesArray2D(DataArr As Variant, Optional isRow As Boolean = True, _
  Optional NumRC = 1, Optional isTrans As Boolean = False, _
  Optional CellsResult As Range) As Variant
    Dim rArr, iStep&, i&, j&, LA1&, UA1&, LA2&, UA2&, iCol&, iRow&, rRow&, rCol&
    LA1 = LBound(DataArr): UA1 = UBound(DataArr)
    LA2 = LBound(DataArr, 2): UA2 = UBound(DataArr, 2)
    ReDim rArr(IIf(isTrans, LA2, LA1) To IIf(isTrans, UA2, UA1), _
               IIf(isTrans, LA1, LA2) To IIf(isTrans, UA1, UA2))
    LA1 = IIf(isRow, LA1, LA2): UA1 = IIf(isRow, UA1, UA2)
    LA2 = IIf(isRow, LA2, LBound(DataArr)): UA2 = IIf(isRow, UA2, UBound(DataArr))
    With CreateObject("Scripting.Dictionary")
        For i = LA1 To UA1
          iRow = IIf(isRow, i, NumRC): iCol = IIf(isRow, NumRC, i)
          If Not .Exists(DataArr(iRow, iCol)) Then
            iStep = iStep + 1
            For j = LA2 To UA2
              rRow = IIf(isRow, iStep, j): rCol = IIf(isRow, j, iStep)
              rArr(IIf(isTrans, rCol, rRow), IIf(isTrans, rRow, rCol)) = DataArr(IIf(isRow, i, j), IIf(isRow, j, i))
            Next j
            .Item(DataArr(iRow, iCol)) = 1
          End If
        Next
      RemoveDupesArray2D = rArr
    End With
    If Not CellsResult Is Nothing Then
      CellsResult.Parent.Cells(CellsResult.Row, CellsResult.Column) _
      .Resize(IIf(isTrans, rCol, rRow), IIf(isTrans, rRow, rCol)).Value = rArr
    End If
  End Function
 
Upvote 0
HeSanbi đã viết:
@Nguyễn Hoàng Oanh Thơ
Code dưới của tôi nâng cấp lại code của @snow25, tăng thêm chút khả năng hữu dụng của Hàm

Sử dụng: Nằm ở sub Test
Diễn giải:
Hàm RemoveDupesArray2D sẽ trả lại kết quả của một mảng phụ thuộc tham số nhập vào:
1. DataArr - Nhập mảng
2. isRow - Lọc theo hàng (True) / cột (False)
3. NumRC - Thứ tự Cột hoặc hàng để lọc dữ liệu trùng
4. isTrans - Chuyển đổi mảng từ dọc sang ngang hoặc ngang sang dọc ( True/ False)
5. CellsResult - Nhập vào một Cells . Hàm sẽ trả kết quả tại Cells này

PHP: 
Sub Test_RemoveDupesArray2D()
  Sheet1.Range("A12:AH100").ClearContents
  Dim Arr: Arr = Sheet1.Range("A1:Q2").Value
    Call RemoveDupesArray2D(Arr, NumRC:=2, isRow:=False, _
                          isTrans:=False, CellsResult:=Sheet1.Range("A4"))
     
    Call RemoveDupesArray2D(Arr, NumRC:=2, isRow:=False, _
                          isTrans:=True, CellsResult:=Sheet1.Range("S4"))

    Call RemoveDupesArray2D(Arr, NumRC:=1, isRow:=True, _
                          isTrans:=False, CellsResult:=Sheet1.Range("A22"))
                         
    Call RemoveDupesArray2D(Arr, NumRC:=1, isRow:=True, _
                          isTrans:=True, CellsResult:=Sheet1.Range("S22"))
   
End Sub
  Function RemoveDupesArray2D(DataArr As Variant, Optional isRow As Boolean = True, _
  Optional NumRC = 1, Optional isTrans As Boolean = False, _
  Optional CellsResult As Range) As Variant
    Dim rArr, iStep&, i&, j&, LA1&, UA1&, LA2&, UA2&, iCol&, iRow&, rRow&, rCol&
    LA1 = LBound(DataArr): UA1 = UBound(DataArr)
    LA2 = LBound(DataArr, 2): UA2 = UBound(DataArr, 2)
    ReDim rArr(IIf(isTrans, LA2, LA1) To IIf(isTrans, UA2, UA1), _
               IIf(isTrans, LA1, LA2) To IIf(isTrans, UA1, UA2))
    LA1 = IIf(isRow, LA1, LA2): UA1 = IIf(isRow, UA1, UA2)
    LA2 = IIf(isRow, LA2, LBound(DataArr)): UA2 = IIf(isRow, UA2, UBound(DataArr))
    With CreateObject("Scripting.Dictionary")
        For i = LA1 To UA1
          iRow = IIf(isRow, i, NumRC): iCol = IIf(isRow, NumRC, i)
          If Not .Exists(DataArr(iRow, iCol)) Then
            iStep = iStep + 1
            For j = LA2 To UA2
              rRow = IIf(isRow, iStep, j): rCol = IIf(isRow, j, iStep)
              rArr(IIf(isTrans, rCol, rRow), IIf(isTrans, rRow, rCol)) = DataArr(IIf(isRow, i, j), IIf(isRow, j, i))
            Next j
            .Item(DataArr(iRow, iCol)) = 1
          End If
        Next
      RemoveDupesArray2D = rArr
    End With
    If Not CellsResult Is Nothing Then
      CellsResult.Parent.Cells(CellsResult.Row, CellsResult.Column) _
      .Resize(IIf(isTrans, rCol, rRow), IIf(isTrans, rRow, rCol)).Value = rArr
    End If
  End Function
Nhấp chuột vào đây để mở rộng...

Xin chào HeSanbi, cảm ơn bạn nhiều ạ.
Nhìn code thấy khiếp quá, khuya về OT test thử rồi thông tin đến bạn sau ạ.
 
Upvote 0
PacificPR đã viết:
Em cũng học theo kiểu của Bạn ý. Hôm trước có Anh nói là học theo kiểu "Tụt từ ngọn xuống gốc" đấy ạ
Nhấp chuột vào đây để mở rộng...
"Anh" nào vậy? Nếu là tôi xin lỗi, rút lại lời ấy.
Lời nói ấy có lẽ được phán ra trước khi tôi nghiệm được cái chân lý rằng ở diễn đàn này chả có "ngọn" và "gốc" gì cả.

tam888 đã viết:
Học kiểu đó , cảm giác nhanh có ích
nhưng động vào code bài khác khác kiểu đã biết, là dễ tẩu hỏa
Tuy thế cũng có nhiều người có đầu óc nhanh nhạy và thích ứng tốt - và thành công
Nhấp chuột vào đây để mở rộng...
Thời buổi công nghệ thông tin súp pưo hai quê, "tẩu hoả" chả sao cả. Chỉ việc đem cái "bài khác khác kiểu đã biết" lên đây hỏi. Sẽ có người giải quyết cho.

Và "thành công" chả liên quan gì đến học cốt kiếc. Bất cứ điều gì cũng có thể lên diễn đàn mà hỏi.
Tôi đã từng thấy một cái pơ rô dét to tổ bố nhờ ở đây cốt từ A đến Z.
 
Upvote 0
VetMini đã viết:
"Anh" nào vậy? Nếu là tôi xin lỗi, rút lại lời ấy.
Lời nói ấy có lẽ được phán ra trước khi tôi nghiệm được cái chân lý rằng ở diễn đàn này chả có "ngọn" và "gốc" gì cả.


Thời buổi công nghệ thông tin súp pưo hai quê, "tẩu hoả" chả sao cả. Chỉ việc đem cái "bài khác khác kiểu đã biết" lên đây hỏi. Sẽ có người giải quyết cho.

Và "thành công" chả liên quan gì đến học cốt kiếc. Bất cứ điều gì cũng có thể lên diễn đàn mà hỏi.
Tôi đã từng thấy một cái pơ rô dét to tổ bố nhờ ở đây cốt từ A đến Z.
Nhấp chuột vào đây để mở rộng...
Thời buổi này ăn nhau là biết cách "tìm kiếm" thông tin ... trên google.
Và biết cách sử dụng, ghép các "mẩu" thông tin với nhau. Được thế thì cứ thỉnh thoảng lại "cưỡi" Mada mới. :D
 
Upvote 0
VetMini đã viết:
"Anh" nào vậy? Nếu là tôi xin lỗi, rút lại lời ấy.
Lời nói ấy có lẽ được phán ra trước khi tôi nghiệm được cái chân lý rằng ở diễn đàn này chả có "ngọn" và "gốc" gì cả.


Thời buổi công nghệ thông tin súp pưo hai quê, "tẩu hoả" chả sao cả. Chỉ việc đem cái "bài khác khác kiểu đã biết" lên đây hỏi. Sẽ có người giải quyết cho.

Và "thành công" chả liên quan gì đến học cốt kiếc. Bất cứ điều gì cũng có thể lên diễn đàn mà hỏi.
Tôi đã từng thấy một cái pơ rô dét to tổ bố nhờ ở đây cốt từ A đến Z.
Nhấp chuột vào đây để mở rộng...
Ah, đó là nói chung cho những người chot dại đam mê code và cái diễn đàn này...

Còn nhanh nhạy là nhờ nhanh, lật nhanh ... thì thành công đi 4 bánh
 
Upvote 0
Xin chào các bạn,
Nhờ các bạn giúp đỡ Oanh Thơ trường hợp tìm ngày giờ lớn nhất trong mảng dữ liệu theo file gửi kèm với ạ.



Untitled.png
 

File đính kèm

Upvote 0
Nguyễn Hoàng Oanh Thơ đã viết:
Xin chào các bạn,
Nhờ các bạn giúp đỡ Oanh Thơ trường hợp tìm ngày giờ lớn nhất trong mảng dữ liệu theo file gửi kèm với ạ.



View attachment 212006
Nhấp chuột vào đây để mở rộng...
Code viết theo "y chang" dữ liệu của bạn, không "bảo hành" với dữ liệu kiểu "nếu...".
Ô H2 format kiểu gì tùy bạn.
PHP: 
Option Explicit

Public Sub sGpe()
Dim sArr(), I As Long, R As Long, Txt As String, Tem As Double, KQ As Double
sArr = Range("C1", Range("C1").End(xlDown)).Value
R = UBound(sArr)
For I = 1 To R
    If sArr(I, 1) Like "Ngay Gio:*" Then
        Txt = Right(sArr(I, 1), 16)
        Tem = DateSerial(Mid(Txt, 7, 4), Mid(Txt, 4, 2), Left(Txt, 2)) + TimeSerial(Mid(Txt, 12, 2), Right(Txt, 2), 0)
        If Tem > KQ Then KQ = Tem
    End If
Next I
Range("H2") = KQ
End Sub
 
Upvote 0
Ba Tê đã viết:
Code viết theo "y chang" dữ liệu của bạn, không "bảo hành" với dữ liệu kiểu "nếu...".
Ô H2 format kiểu gì tùy bạn.
PHP: 
Option Explicit

Public Sub sGpe()
Dim sArr(), I As Long, R As Long, Txt As String, Tem As Double, KQ As Double
sArr = Range("C1", Range("C1").End(xlDown)).Value
R = UBound(sArr)
For I = 1 To R
    If sArr(I, 1) Like "Ngay Gio:*" Then
        Txt = Right(sArr(I, 1), 16)
        Tem = DateSerial(Mid(Txt, 7, 4), Mid(Txt, 4, 2), Left(Txt, 2)) + TimeSerial(Mid(Txt, 12, 2), Right(Txt, 2), 0)
        If Tem > KQ Then KQ = Tem
    End If
Next I
Range("H2") = KQ
End Sub
Nhấp chuột vào đây để mở rộng...

Xin chào Thầy Ba Tê:
Con cảm ơn Thầy đã giúp đỡ ạ, code trên của Thầy con ứng dụng OK rồi ạ.
Thầy và các bạn cho OT hỏi thêm trong trường hợp dữ liệu là:
Ngay Gio: 21/1/2019 06:00 giống với kiểu định dạng "Ngay Gio: "d/m/yyyy hh:mm.
Thì code trên sẽ viết như thế nào để có thể sử dụng được mà không phải sửa tay các con số trong hàm Mid ạ.
 
Upvote 0
Nguyễn Hoàng Oanh Thơ đã viết:
Xin chào Thầy Ba Tê:
Con cảm ơn Thầy đã giúp đỡ ạ, code trên của Thầy con ứng dụng OK rồi ạ.
Thầy và các bạn cho OT hỏi thêm trong trường hợp dữ liệu là:
Ngay Gio: 21/1/2019 06:00 giống với kiểu định dạng "Ngay Gio: "d/m/yyyy hh:mm.
Thì code trên sẽ viết như thế nào để có thể sử dụng được mà không phải sửa tay các con số trong hàm Mid ạ.
Nhấp chuột vào đây để mở rộng...
Yêu cầu của bạn đòi hỏi phải chuẩn hóa ngày. Cách ít phiền phức nhất là dùng một hàm chuẩn hóa ngày về dạng "universal" - tức là dạng yyyy/mm/dd hoặc yyyy-mm-dd

Bên thớt "Những câu hỏi về lập trình..." tôi có giới thiệu sơ qua về cái hàm chuyển đổi dạng chuẩn này.
Công việc của bạn là sửa code ở bài #1129 như sau:
1. Dùng hàm Replace để biến "Ngay Gio:" thành "", và Trim
2. Dùng hàm Split theo " " để lấy phần ngày ở đầu
3. Dùng hàm UniversalDate để đổi phần tử đầu (chỉ số 0) thành dạng yyyy/mm/dd - vì ở đây bạn có sẵn dạng dd/mm/yyyy cho nên tham thứ hai nạp cho hàm UniversalDate là "EU"
4. Dùng hàm Join để join lại theo " "
5. Bây giờ Txt là dạng ngày giờ chuẩn cho nên bạn có thể giản dị dùng hàm CDate để đổi nó thành ngày giờ.

Function UniversalDate(ByVal d As String, Optional inTyp As String = "US") As String
' function to change date string from dd/mm/yyyy (inTyp = "EU"), or mm/dd/yyyy (inTyp="US") to yyyy/mm/dd
Dim x() As String
x = Split(d, "/")
If Len(x(2)) < 4 Then x(2) = CStr(2000 + Val(x2)) ' normalise year
If UCase(inTyp) = "US" Then
UniversalDate = x(2) & "/" & x(0) & "/" & x(1)
Else
UniversalDate = x(2) & "/" & x(1) & "/" & x(0)
End If
End Function
 
Upvote 0
VetMini đã viết:
Yêu cầu của bạn đòi hỏi phải chuẩn hóa ngày. Cách ít phiền phức nhất là dùng một hàm chuẩn hóa ngày về dạng "universal" - tức là dạng yyyy/mm/dd hoặc yyyy-mm-dd

Bên thớt "Những câu hỏi về lập trình..." tôi có giới thiệu sơ qua về cái hàm chuyển đổi dạng chuẩn này.
Công việc của bạn là sửa code ở bài #1129 như sau:
1. Dùng hàm Replace để biến "Ngay Gio:" thành "", và Trim
2. Dùng hàm Split theo " " để lấy phần ngày ở đầu
3. Dùng hàm UniversalDate để đổi phần tử đầu (chỉ số 0) thành dạng yyyy/mm/dd - vì ở đây bạn có sẵn dạng dd/mm/yyyy cho nên tham thứ hai nạp cho hàm UniversalDate là "EU"
4. Dùng hàm Join để join lại theo " "
5. Bây giờ Txt là dạng ngày giờ chuẩn cho nên bạn có thể giản dị dùng hàm CDate để đổi nó thành ngày giờ.

Function UniversalDate(ByVal d As String, Optional inTyp As String = "US") As String
' function to change date string from dd/mm/yyyy (inTyp = "EU"), or mm/dd/yyyy (inTyp="US") to yyyy/mm/dd
Dim x() As String
x = Split(d, "/")
If Len(x(2)) < 4 Then x(2) = CStr(2000 + Val(x2)) ' normalise year
If UCase(inTyp) = "US" Then
UniversalDate = x(2) & "/" & x(0) & "/" & x(1)
Else
UniversalDate = x(2) & "/" & x(1) & "/" & x(0)
End If
End Function
Nhấp chuột vào đây để mở rộng...

Cảm ơn Bác VetMini nhiều ạ,
Cháu sẽ thử làm theo 5 bước trên nếu gặp khó khăn rất mong lại nhận được sự giúp đỡ của Bác và mọi người ạ.
-----
Nhân dịp đầu xuân cháu kinh chúc Bác cùng gia đình một năm mới An Khang Thịnh Vượng, Vạn Sự Như Ý.
 
Upvote 0
Mà sao CSDL lài có kiểu Ngay Gio: 14/12/2018 18:04 hay vậy ta?
Kiểu này nên chuyển sang xài Words, sẽ êm ngay tấp lự!

Riết rồi các thợ nhà ta chuyên đi gom & phân loại rác!
 
Upvote 0
Nguyễn Hoàng Oanh Thơ đã viết:
Xin chào các bạn,
Nhờ các bạn giúp đỡ Oanh Thơ trường hợp tìm ngày giờ lớn nhất trong mảng dữ liệu theo file gửi kèm với ạ.
Nhấp chuột vào đây để mở rộng...
Nguyễn Hoàng Oanh Thơ đã viết:
Ngay Gio: 21/1/2019 06:00 giống với kiểu định dạng "Ngay Gio: "d/m/yyyy hh:mm.
Thì code trên sẽ viết như thế nào để có thể sử dụng được mà không phải sửa tay các con số trong hàm Mid ạ.
Nhấp chuột vào đây để mở rộng...

Đơn giản là:
Chỉ cần bỏ đi "Ngay Gio: " nếu gặp. Rồi chuyển nó thành thời gian theo định dạng.
So sánh biến đại diện thời gian lớn nhất với nó. Nếu lớn hơn thì cho biến này thành nó

Code dưới tôi chưa kiểm thử (Thang siêng năng của tôi = 1/10, sympathize for me)
PHP: 
Sub test_date()
  Dim Arr(), DArr$(), i&, M#, Str$, D#, DStr$
  With Sheets(1)
    Arr = .Range("C1", .Range("C1").End(xlDown)).Value
    For i = 1 To UBound(Arr)
      If Arr(i, 1) Like "Ngay Gio:*/*/*:*" Then
        Str = Replace(Arr(i, 1), "Ngay Gio: ", "")
        DStr = Left(Str, Len(Str) - 5)
        DArr = Split(DStr, "/")
        D = DateSerial(DArr(2), DArr(1), DArr(0)) + TimeValue(Right(Str, 5))
        M = IIf(D > M, D, M)
      End If
    Next i
    .Range("H2").Value = M
    .Range("H2").NumberFormat = "d/m/yyyy hh:mm"
  End With
End Sub
Code này lấy toàn bộ giá trị lớn nhất gồm "Ngay Gio: ":
PHP: 
Sub test_date1()
  Dim Arr(),DArr$(), i&, M#, D#, MStr$, Str$
  With Sheets(1)
    Arr = .Range("C1", .Range("C1").End(xlDown)).Value
    For i = 1 To UBound(Arr)
      If Arr(i, 1) Like "Ngay Gio:*/*/*:*" Then
        Str = Replace(Arr(i, 1), "Ngay Gio: ", "")
        DStr = Left(Str, Len(Str) - 5)
        DArr = Split(DStr, "/")
        D = DateSerial(DArr(2), DArr(1), DArr(0)) + TimeValue(Right(Str, 5))
        If (D > M) Then M = D: MStr = Arr(i, 1)
      End If
    Next i
    .Range("H2").Value = MStr
  End With
End Sub
 
Lần chỉnh sửa cuối:
Upvote 0
HeSanbi đã viết:
Đơn giản là:
Chỉ cần bỏ đi "Ngay Gio: " nếu gặp. Rồi chuyển nó thành thời gian bằng hàm CDate.
...
Nhấp chuột vào đây để mở rộng...
Đơn giản nhất và cũng là phương pháp NGUY HIỂM nhất.
Hàm CDate dựa trên mặc định máy để hiểu đầu vào là dạng dd/mm hay mm/dd. Tuy nhiên, nếu thấy tháng lớn hơn 12 thì nó sẽ tự động chuyển bên này sang bên kia. Cuối cùng sẽ nhận được một kết quả mà mình cũng chả biết là đúng hay sai.

CDate("31/01/2019") và CDate("01/31/2019") đều ra ngày 31 tháng Giêng 2019. Không tùy thuộc hệ thống.

(*) chịu khó đọc bài bên "giải đáp thắc mắc về code...", các bài ngày 07/02/2019 có giải thích rõ hơn về mặc định ngày tháng này.
 
Upvote 0
@Nguyễn Hoàng Oanh Thơ

Nếu CDate bó tay thì dùng "Spring Date"
PHP: 
Sub test_date()
  Dim Arr(), DArr$(), i&, M#, Str$, D#, DStr$
  With Sheets(1)
    Arr = .Range("C1", .Range("C1").End(xlDown)).Value
    For i = 1 To UBound(Arr)
      If Arr(i, 1) Like "Ngay Gio:*/*/*:*" Then
        Str = Replace(Arr(i, 1), "Ngay Gio: ", "")
        DStr = Left(Str, Len(Str) - 5)
        DArr = Split(DStr, "/")
        D = DateSerial(DArr(2), DArr(1), DArr(0)) + TimeValue(Right(Str, 5))
        M = IIf(D > M, D, M)
      End If
    Next i
    .Range("H2").Value = M
    .Range("H2").NumberFormat = "d/m/yyyy hh:mm"
  End With
End Sub
Sub test_date1()
  Dim Arr(),DArr$(), i&, M#, D#, MStr$, Str$
  With Sheets(1)
    Arr = .Range("C1", .Range("C1").End(xlDown)).Value
    For i = 1 To UBound(Arr)
      If Arr(i, 1) Like "Ngay Gio:*/*/*:*" Then
        Str = Replace(Arr(i, 1), "Ngay Gio: ", "")
        DStr = Left(Str, Len(Str) - 5)
        DArr = Split(DStr, "/")
        D = DateSerial(DArr(2), DArr(1), DArr(0)) + TimeValue(Right(Str, 5))
        If (D > M) Then M = D: MStr = Arr(i, 1)
      End If
    Next i
    .Range("H2").Value = MStr
  End With
End Sub
 
Lần chỉnh sửa cuối:
Upvote 0
SA_DQ đã viết:
Mà sao CSDL lài có kiểu Ngay Gio: 14/12/2018 18:04 hay vậy ta?
Kiểu này nên chuyển sang xài Words, sẽ êm ngay tấp lự!

Riết rồi các thợ nhà ta chuyên đi gom & phân loại rác!
Nhấp chuột vào đây để mở rộng...
Cảm ơn bác SA_DQ đã quan tâm ạ, có thể bác không tin nhưng CSDL kiểu đó lại chính là dữ liệu xuất ra từ phần mềm.
Những chỗ không liên quan(không cần thiết) nên Oanh Thơ đã thay bằng dữ liệu minh họa.
----------
HeSanbi đã viết:
@Nguyễn Hoàng Oanh Thơ

Nếu CDate bó tay thì dùng "Spring Date"
PHP: 
Sub test_date()
  Dim Arr(), DArr(), i&, M#, Str$, D#, DStr$
  With Sheets(1)
    Arr = .Range("C1", .Range("C1").End(xlDown)).Value
    For i = 1 To UBound(Arr)
      If Arr(i, 1) Like "Ngay Gio:*/*/*:*" Then
        Str = Replace(Arr(i, 1), "Ngay Gio: ", "")
        DStr = Left(Str, Len(Str) - 5)
        DArr = Split(DStr, "/")
        D = DateSerial(DArr(2), DArr(1), DArr(0)) + TimeValue(Right(Str, 5))
        M = IIf(D > M, D, M)
      End If
    Next i
    .Range("H2").Value = M
    .Range("H2").NumberFormat = "d/m/yyyy hh:mm"
  End With
End Sub
Sub test_date1()
  Dim Arr(),DArr(), i&, M#, D#, MStr$, Str$
  With Sheets(1)
    Arr = .Range("C1", .Range("C1").End(xlDown)).Value
    For i = 1 To UBound(Arr)
      If Arr(i, 1) Like "Ngay Gio:*/*/*:*" Then
        Str = Replace(Arr(i, 1), "Ngay Gio: ", "")
        DStr = Left(Str, Len(Str) - 5)
        DArr = Split(DStr, "/")
        D = DateSerial(DArr(2), DArr(1), DArr(0)) + TimeValue(Right(Str, 5))
        If (D > M) Then M = D: MStr = Arr(i, 1)
      End If
    Next i
    .Range("H2").Value = MStr
  End With
End Sub
Nhấp chuột vào đây để mở rộng...

Xin chào HeSanbi,
Cảm ơn bạn nhiều, các code trên đều bị lỗi "Type mismatch" tại dòng: DArr = Split(DStr, "/").
Nhờ bạn xem giúp.
 
Upvote 0
bác SA_DQ ạ, nhưng CSDL kiểu đó lại chính là dữ liệu xuất ra từ phần mềm.
Những chỗ không liên quan(không cần thiết) nên Oanh Thơ đã thay bằng dữ liệu minh họa..
Nhấp chuột vào đây để mở rộng...
Vậy trước khi xử lý hay tính toán tiếp, ta làm 1 macro xử lý đưa về thành dữ liệu chuẩn hơn, được không?
 
Upvote 0
Được ạ, nhưng bước này có thể xử lý trong mảng mà không ảnh hưởng(thay đổi) gì dữ liệu gốc trên sheet được không ạ?
Nhấp chuột vào đây để mở rộng...
Bạn hoàn toàn có thể thử mà!
Làm thế này đi, xem sao:
Tạo vòng lặp duyệt cột C; Nếu gặp cụm từ "Ngay gio: " thì bỏ bén đi
 
Upvote 0
Mong các anh giúp em trường hợp về mảng! Như file đính kèm.
- Quét Date ở ô L5 với mảng Ngay = Range("G4:I4").value nếu có ngày trùng thì
Quét tiếp Type ở Range("N5") với mảng CHUAN =Range("G5:J7").value nếu Type trùng thì
add Name ở Range("M5").value vào mang GT = Range("G8:I10").value với row/col vừa tìm được: GT(j,i) = Range("M5").value

Mã: 
Sub Test()
Dim Ngay As Variant, GT As Variant, CHUAN As Variant
Ngay = Range("G4:I4").Value
CHUAN = Range("G5:I7").Value
GT = Range("G8:I10").Value
        For i = 1 To 3
            For j = 1 To 3
                 If Ngay(1, i) = Range("L5").Value Then
                     If CHUAN(j, i) = Range("N5").Value Then     'Type: E
                         GT(j, i) = Range("M5").Value                'Name: Nguyen A

                     End If
                 End If
            Next j
        Next i
MsgBox ("Done")
End Sub

1.> Khi em chạy xong Name: Nguye A không được add vào cell GT(j,i), em đang tìm hiểu về mảng đọc trong topic này nhưng chưa tìm ra nguyên nhân
2.> Với GT(j,i) em muốn xác định địa chỉ ô excel của nó thì làm thế nào ạ! Row/cell = ? ( kiểu như cells(m,n))
3.> Để thực hiện yêu cầu trên còn cách nào tối ưu hơn không ạ!
Em cảm ơn các anh nhiều!
 

File đính kèm

Lần chỉnh sửa cuối:
Upvote 0
alias1313 đã viết:
Mong các anh giúp em trường hợp về mảng! Như file đính kèm.
- Quét Date ở ô L5 với mảng Ngay = Range("G4:I4").value nếu có ngày trùng thì
Quét tiếp Type ở Range("N5") với mảng CHUAN =Range("G5:J7").value nếu Type trùng thì
add Name ở Range("M5").value vào mang GT = Range("G8:I10").value với row/col vừa tìm được: GT(j,i) = Range("M5").value

Mã: 
Sub Test()
Dim Ngay As Variant, GT As Variant, CHUAN As Variant
Ngay = Range("G4:I4").Value
CHUAN = Range("G5:I7").Value
GT = Range("G8:I10").Value
        For i = 1 To 3
            For j = 1 To 3
                 If Ngay(1, i) = Range("L5").Value Then
                     If CHUAN(j, i) = Range("N5").Value Then     'Type: E
                         GT(j, i) = Range("M5").Value                'Name: Nguyen A

                     End If
                 End If
            Next j
        Next i
MsgBox ("Done")
End Sub

1.> Khi em chạy xong Name: Nguye A không được add vào cell GT(j,i), em đang tìm hiểu về mảng đọc trong topic này nhưng chưa tìm ra nguyên nhân
2.> Với GT(j,i) em muốn xác định địa chỉ ô excel của nó thì làm thế nào ạ! Row/cell = ? ( kiểu như
3.> Để thực hiện yêu cầu trên còn cách nào tối ưu hơn không ạ!
Em cảm ơn các anh nhiều!
Nhấp chuột vào đây để mở rộng...
Bạn viết code rồi.Vậy bạn muốn thế nào.Mà có file nào đâu nhỉ.
 
Upvote 0
alias1313 đã viết:
Em mới up file lên rồi ạ!
Em muốn add Name: Nguyen A vào mảng GT với dữ liệu xác định là: ngày và Type : E!
Mong anh @snow25 giúp đỡ!
Nhấp chuột vào đây để mở rộng...
Bạn điền nó vào mảng rồi thì phải gắn nó lại excel chứ.Thêm câu lệnh này vào.
Mã: 
Range("G8:I10").Value = GT
 
Upvote 0
snow25 đã viết:
Bạn điền nó vào mảng rồi thì phải gắn nó lại excel chứ.Thêm câu lệnh này vào.
Mã: 
Range("G8:I10").Value = GT
Nhấp chuột vào đây để mở rộng...
Hà hà! Thì ra vậy! em làm được rồi! Cảm ơn anh nhiều!
2.> Với GT(j,i) em muốn xác định địa chỉ ô excel của nó thì làm thế nào ạ! Row/cell = ? ( kiểu như cells(m,n))
Mình có thể xác định vị trí cells ko anh!
 
Upvote 0
alias1313 đã viết:
Hà hà! Thì ra vậy! em làm được rồi! Cảm ơn anh nhiều!
2.> Với GT(j,i) em muốn xác định địa chỉ ô excel của nó thì làm thế nào ạ! Row/cell = ? ( kiểu như cells(m,n))
Mình có thể xác định vị trí cells ko anh!
Nhấp chuột vào đây để mở rộng...
Vậy tùy bạn thôi bạn xem vị trí nó ở đâu rồi cộng thêm vào cho giống địa chỉ ở excel là được mà.:D
 
Upvote 0
snow25 đã viết:
Vậy tùy bạn thôi bạn xem vị trí nó ở đâu rồi cộng thêm vào cho giống địa chỉ ở excel là được mà.:D
Nhấp chuột vào đây để mở rộng...
Anh cho em hỏi thêm!
Em có 3 Array: GT , BT, QT
em muốn dùng một tên đại diện cho 3 array đó = Arr1 để em gọi khi cần kiểu như:
If Range("A1").value = "BT" then ( thì gán tên BT cho Arr1 )
Arr1(j,i) = Range("M5").Value ( thay cho: BT(j, i) = Range("M5").Value )
hay mình có thể:
Range("A1").Value & "(j,i) = Range("M5").Value ( thay cho: BT(j, i) = Range("M5").Value )

Không biết mình có cách nào làm vậy không anh!
em cũng có thử kiểu dưới nhưng không được!
Mã: 
Sub test

dim Arr2

Arr2 = Array("GT", "BT", "QT", "KT")

      For k = 1 to 4

          If Arr2(k) = Range("A1").Value Then

                Arr2(j, i) = Range("M5").Value  

          end if

      next for

End sub


Mong anh giúp đỡ!
 
Upvote 0
alias1313 đã viết:
Anh cho em hỏi thêm!
Em có 3 Array: GT , BT, QT
em muốn dùng một tên đại diện cho 3 array đó = Arr1 để em gọi khi cần kiểu như:
If Range("A1").value = "BT" then ( thì gán tên BT cho Arr1 )
Arr1(j,i) = Range("M5").Value ( thay cho: BT(j, i) = Range("M5").Value )
hay mình có thể:
Range("A1").Value & "(j,i) = Range("M5").Value ( thay cho: BT(j, i) = Range("M5").Value )

Không biết mình có cách nào làm vậy không anh!
em cũng có thử kiểu dưới nhưng không được!
Mã: 
Sub test

dim Arr2

Arr2 = Array("GT", "BT", "QT", "KT")

      For k = 1 to 4

          If Arr2(k) = Range("A1").Value Then

                Arr2(j, i) = Range("M5").Value 

          end if

      next for

End sub


Mong anh giúp đỡ!
Nhấp chuột vào đây để mở rộng...
Mục đích bạn làm vậy để làm gì nhỉ.
 
Upvote 0
snow25 đã viết:
Mục đích bạn làm vậy để làm gì nhỉ.
Nhấp chuột vào đây để mở rộng...
Cái này để em thêm tên nhân viên vào bảng công tương ứng.
Em Quét ngày, nếu có ngày thì quét Group xác định Goup
Quét Type ở mảng CHUAN để đưa ra vị trí tương ứng sau khi có vị trí nhờ Type thi
Điền tên Nguyen A vào Goup tương ứng với vị trí Type tương ứng vừa xác định .
Em có add file đính kèm anh xem giúp em!
 

File đính kèm

Upvote 0
alias1313 đã viết:
Cái này để em thêm tên nhân viên vào bảng công tương ứng.
Em Quét ngày, nếu có ngày thì quét Group xác định Goup
Quét Type ở mảng CHUAN để đưa ra vị trí tương ứng sau khi có vị trí nhờ Type thi
Điền tên Nguyen A vào Goup tương ứng với vị trí Type tương ứng vừa xác định .
Em có add file đính kèm anh xem giúp em!
Nhấp chuột vào đây để mở rộng...
Bạn đưa dữ liệu chuẩn lên đây mình thử code xem được không nhé.
 
Upvote 0
alias1313 đã viết:
Cái này để em thêm tên nhân viên vào bảng công tương ứng.
Em Quét ngày, nếu có ngày thì quét Group xác định Goup
Quét Type ở mảng CHUAN để đưa ra vị trí tương ứng sau khi có vị trí nhờ Type thi
Điền tên Nguyen A vào Goup tương ứng với vị trí Type tương ứng vừa xác định .
Em có add file đính kèm anh xem giúp em!
Nhấp chuột vào đây để mở rộng...
Dữ liệu chẳng logic gì cả.
Nếu chỉ có 2 nhóm thì tạo thành "4 vùng chiến thuật" để xử lý.
Nếu tùm lum nhóm thì phải đưa dữ liệu giống thật mới xử được.
PHP: 
Public Sub sGpe()
Const Col As Long = 3
Const Rws As Long = 3
Dim Gr1(), Gr2(), Arr(), Dat()
Dim I As Long, J As Long, Ngay As Date, Typ As String, Grp As String, Txt As String
        Dat = Range("G4").Resize(, Col).Value
        Arr = Range("G5").Resize(Rws, Col).Value
        Gr1 = Range("G8").Resize(Rws, Col).Value
        Gr2 = Range("G12").Resize(Rws, Col).Value
    Ngay = Range("L5").Value
    Txt = Range("M5").Value
    Typ = Range("N5").Value
    Grp = Right(Range("O5"), 1)
For J = 1 To Col
    If Dat(1, J) = Ngay Then
        For I = 1 To Rws
            If Arr(I, J) = Typ Then
                If Grp = "1" Then
                    Gr1(I, J) = Txt
                    Range("G8").Resize(Rws, Col) = Gr1
                Else
                    Gr2(I, J) = Txt
                    Range("G12").Resize(Rws, Col) = Gr2
                End If
                Exit For
            End If
        Next I
        Exit For
    End If
Next J
End Sub
 
Upvote 0
alias1313 đã viết:
Cái này để em thêm tên nhân viên vào bảng công tương ứng.
Em Quét ngày, nếu có ngày thì quét Group xác định Goup
Quét Type ở mảng CHUAN để đưa ra vị trí tương ứng sau khi có vị trí nhờ Type thi
Điền tên Nguyen A vào Goup tương ứng với vị trí Type tương ứng vừa xác định .
Em có add file đính kèm anh xem giúp em!
Nhấp chuột vào đây để mở rộng...
Bài này thì nên thay đổi cách bố trí dữ liệu thì sẽ tiện lợi hơn nhiều, có khi không cần CODE
 
Upvote 0
alias1313 đã viết:
....
em cũng có thử kiểu dưới nhưng không được!
Mã: 
Sub test

dim Arr2

Arr2 = Array("GT", "BT", "QT", "KT")

      For k = 1 to 4

          If Arr2(k) = Range("A1").Value Then

                Arr2(j, i) = Range("M5").Value

          end if

      next for

End sub
Nhấp chuột vào đây để mở rộng...
"không được" tức là sao?
ít nhất cũng phải cho người ta biết chi tiết của cái "không được" ấy.
Đoạn code trên chưa cần biết đúng hay sai. Trước mắt là trật thuật ngữ.
Arr2 = Array("GT", "BT", "QT", "KT") ' Arr2 được gán cho cái mảng 1 chiều
...
Arr2(j, i) = Range("M5").Value ' i là chỉ số chiều thứ hai - chiều này ở đâu ra?
 
Upvote 0
Em thành thật xin lỗi! Vì việc đưa dữ liệu không chuẩn đã gây ra những phiền toái và mất thời gian của các anh!
Em xin ghi nhớ điều này! Cũng mong các anh thông cảm vì một người kiến thức lập trình còn yếu không lường hết được sự việc.
Em xin up lại dữ liệu chuẩn theo công việc mong các anh giúp em!
Mới đầu em chỉ nghĩ hỏi từng phần để vừa làm vừa hỏi cho hiểu về mảng.
Nội dung công việc của em:

-Em tạo một bảng dữ liệu đi ca.
-Gồm 6 nhóm, mỗi nhóm phụ trách 1 công việc khác nhau. Đi theo lịch đi ca như bảng CHUAN.
-Khi nhân viên muốn đổi ca em muốn cập nhật tên nhân viên vào bảng đi ca tương ứng dựa vào : Ngày đổi, ca đi, nhóm, tên.
Em có add file đính kèm!
Mong các anh giúp em!
Bài đã được tự động gộp:

Ba Tê đã viết:
Dữ liệu chẳng logic gì cả.
Nếu chỉ có 2 nhóm thì tạo thành "4 vùng chiến thuật" để xử lý.
Nếu tùm lum nhóm thì phải đưa dữ liệu giống thật mới xử được.
PHP: 
Public Sub sGpe()
Const Col As Long = 3
Const Rws As Long = 3
Dim Gr1(), Gr2(), Arr(), Dat()
Dim I As Long, J As Long, Ngay As Date, Typ As String, Grp As String, Txt As String
        Dat = Range("G4").Resize(, Col).Value
        Arr = Range("G5").Resize(Rws, Col).Value
        Gr1 = Range("G8").Resize(Rws, Col).Value
        Gr2 = Range("G12").Resize(Rws, Col).Value
    Ngay = Range("L5").Value
    Txt = Range("M5").Value
    Typ = Range("N5").Value
    Grp = Right(Range("O5"), 1)
For J = 1 To Col
    If Dat(1, J) = Ngay Then
        For I = 1 To Rws
            If Arr(I, J) = Typ Then
                If Grp = "1" Then
                    Gr1(I, J) = Txt
                    Range("G8").Resize(Rws, Col) = Gr1
                Else
                    Gr2(I, J) = Txt
                    Range("G12").Resize(Rws, Col) = Gr2
                End If
                Exit For
            End If
        Next I
        Exit For
    End If
Next J
End Sub
Nhấp chuột vào đây để mở rộng...
Cảm ơn anh đã giúp em ! em đã test code chạy đúng theo yêu cầu của em!
Anh có thể giúp em thêm file bên dưới được không anh!
Bài đã được tự động gộp:

snow25 đã viết:
Bạn đưa dữ liệu chuẩn lên đây mình thử code xem được không nhé.
Nhấp chuột vào đây để mở rộng...
Mong anh @snow25 giúp đỡ!
 

File đính kèm

Upvote 0
alias1313 đã viết:
Em thành thật xin lỗi! Vì việc đưa dữ liệu không chuẩn đã gây ra những phiền toái và mất thời gian của các anh!
Em xin ghi nhớ điều này! Cũng mong các anh thông cảm vì một người kiến thức lập trình còn yếu không lường hết được sự việc.
Em xin up lại dữ liệu chuẩn theo công việc mong các anh giúp em!
Mới đầu em chỉ nghĩ hỏi từng phần để vừa làm vừa hỏi cho hiểu về mảng.
Nội dung công việc của em:

-Em tạo một bảng dữ liệu đi ca.
-Gồm 6 nhóm, mỗi nhóm phụ trách 1 công việc khác nhau. Đi theo lịch đi ca như bảng CHUAN.
-Khi nhân viên muốn đổi ca em muốn cập nhật tên nhân viên vào bảng đi ca tương ứng dựa vào : Ngày đổi, ca đi, nhóm, tên.
Em có add file đính kèm!
Mong các anh giúp em!
Bài đã được tự động gộp:


Cảm ơn anh đã giúp em ! em đã test code chạy đúng theo yêu cầu của em!
Anh có thể giúp em thêm file bên dưới được không anh!
Bài đã được tự động gộp:


Mong anh @snow25 giúp đỡ!
Nhấp chuột vào đây để mở rộng...
Đây bạn xem.Có đúng không nhé.
Mã: 
Sub doiulieu()
Dim arr, arr1, dic As Object, i As Long, lr As Long, j As Long, dk As String, dks As String, b As Long, c As Long, d As Long
Set dic = CreateObject("scripting.dictionary")
With Sheet1
     arr = .Range("D5:n9").Value
     For j = 1 To UBound(arr, 2)
         For i = 3 To UBound(arr, 1)
             dk = CLng(arr(1, j)) & "#" & arr(i, j)
             If Not dic.exists(dk) Then
                dic.Item(dk) = Array(i - 4, j)
             End If
         Next i
     Next j
     lr = .Range("D" & Rows.Count).End(xlUp).Row
     If lr < 11 Then Exit Sub
     arr = .Range("a11:N" & lr).Value
     For i = 1 To UBound(arr, 1)
         If Len(arr(i, 1)) > 0 Then
            If Not dic.exists(arr(i, 1)) Then
               dic.Add arr(i, 1), i
            End If
         End If
     Next i
     dk = CLng(.Range("T14").Value) & "#" & .Range("V14").Value
     dks = .Range("W14").Value
     If dic.exists(dk) Then
           b = dic.Item(dk)(0)
           c = dic.Item(dk)(1)
         If dic.exists(dks) Then
            d = dic.Item(dks)
            arr(b + d, c + 3) = .Range("u14").value
           End If
      End If
      .Range("a11:N" & lr).Value = arr
End With
End Sub
 

File đính kèm

Lần chỉnh sửa cuối:
Upvote 0
snow25 đã viết:
Đây bạn xem.Có đúng không nhé.
Mã: 
Sub doiulieu()
Dim arr, arr1, dic As Object, i As Long, lr As Long, j As Long, dk As String, dks As String, b As Long, c As Long, d As Long
Set dic = CreateObject("scripting.dictionary")
With Sheet1
     arr = .Range("D5:n9").Value
     For j = 1 To UBound(arr, 2)
         For i = 3 To UBound(arr, 1)
             dk = CLng(arr(1, j)) & "#" & arr(i, j)
             If Not dic.exists(dk) Then
                dic.Item(dk) = Array(i - 4, j)
             End If
         Next i
     Next j
     lr = .Range("D" & Rows.Count).End(xlUp).Row
     If lr < 11 Then Exit Sub
     arr = .Range("a11:N" & lr).Value
     For i = 1 To UBound(arr, 1)
         If Len(arr(i, 1)) > 0 Then
            If Not dic.exists(arr(i, 1)) Then
               dic.Add arr(i, 1), i
            End If
         End If
     Next i
     dk = CLng(.Range("T14").Value) & "#" & .Range("V14").Value
     dks = .Range("W14").Value
     If dic.exists(dk) Then
           b = dic.Item(dk)(0)
           c = dic.Item(dk)(1)
         If dic.exists(dks) Then
            d = dic.Item(dks)
            arr(b + d, c + 3) = .Range("u14").value
           End If
      End If
      .Range("a11:N" & lr).Value = arr
End With
End Sub
Nhấp chuột vào đây để mở rộng...
Em đã test, code chạy đúng theo yêu cầu. Nhưng em chưa hiểu cách nó vận hành. Để em ngâm cứu nếu có chỗ nào em không hiểu được anh chỉ em nha.Cảm ơn anh @snow25 nhiều!
@HieuCD em chào anh!
 
Upvote 0
VetMini đã viết:
"không được" tức là sao?
ít nhất cũng phải cho người ta biết chi tiết của cái "không được" ấy.
Đoạn code trên chưa cần biết đúng hay sai. Trước mắt là trật thuật ngữ.
Arr2 = Array("GT", "BT", "QT", "KT") ' Arr2 được gán cho cái mảng 1 chiều
...
Arr2(j, i) = Range("M5").Value ' i là chỉ số chiều thứ hai - chiều này ở đâu ra?
Nhấp chuột vào đây để mở rộng...
Dạ! Tại em ghi không đủ!
Em có 4 Array: GT , BT, QT,KT
GT = Range("A1:C5").value
BT = Range("D1:H5").value
QT = Range("A10: E13").value
KT = Range("M10:O15").value
Em muốn dùng một tên đại diện cho 4 array đó ví dụ là: Name_arr để em gọi khi cần kiểu như:
If Range("J15").value = "GT" then ( thì gán tên mảng GT cho Name_arr )sau khi gán:
Name_arr(2,2) chính là ô B2 ( GT = Range("A1:C5").value) : Em đã thử nhưng không được.
Mình có cách nào làm như vậy không ạ! ( tại em muốn tìm hiểu về mảng)
Cảm ơn anh @VetMini đã ghé thăm ^_^!
 
Upvote 0
snow25 đã viết:
Đây bạn xem.Có đúng không nhé.
Mã: 
Sub doiulieu()
Dim arr, arr1, dic As Object, i As Long, lr As Long, j As Long, dk As String, dks As String, b As Long, c As Long, d As Long
Set dic = CreateObject("scripting.dictionary")
With Sheet1
     arr = .Range("D5:n9").Value
     For j = 1 To UBound(arr, 2)
         For i = 3 To UBound(arr, 1)
             dk = CLng(arr(1, j)) & "#" & arr(i, j)
             If Not dic.exists(dk) Then
                dic.Item(dk) = Array(i - 4, j)
             End If
         Next i
     Next j
     lr = .Range("D" & Rows.Count).End(xlUp).Row
     If lr < 11 Then Exit Sub
     arr = .Range("a11:N" & lr).Value
     For i = 1 To UBound(arr, 1)
         If Len(arr(i, 1)) > 0 Then
            If Not dic.exists(arr(i, 1)) Then
               dic.Add arr(i, 1), i
            End If
         End If
     Next i
     dk = CLng(.Range("T14").Value) & "#" & .Range("V14").Value
     dks = .Range("W14").Value
     If dic.exists(dk) Then
           b = dic.Item(dk)(0)
           c = dic.Item(dk)(1)
         If dic.exists(dks) Then
            d = dic.Item(dks)
            arr(b + d, c + 3) = .Range("u14").value
           End If
      End If
      .Range("a11:N" & lr).Value = arr
End With
End Sub
Nhấp chuột vào đây để mở rộng...
Dic thường dùng lưu dữ liệu và truy xuất nhiều lần, bài nầy chỉ tìm 1 lần, dùng Dic khá lãng phí, thử bỏ Dic code sẽ gọn và nhanh hơn
Trong code nên thêm phần thông báo không đổi được do trong ngày, nhóm đó không có ca tương ứng ;)
 
Upvote 0
HieuCD đã viết:
Dic thường dùng lưu dữ liệu và truy xuất nhiều lần, bài nầy chỉ tìm 1 lần, dùng Dic khá lãng phí, thử bỏ Dic code sẽ gọn và nhanh hơn
Trong code nên thêm phần thông báo không đổi được do trong ngày, nhóm đó không có ca tương ứng ;)
Nhấp chuột vào đây để mở rộng...
Em có thử code không sử dụng Dic! Nhưng thấy nó nặng nề quá!

Mã: 
Sub CA()

Dim Ngay As Variant, GT As Variant, CHUAN As Variant
Dim ARR3 As Variant
Dim i
Dim j
Dim k
Dim range1 As Range
Dim Arr8 As Variant
Ngay = Range("D5:N5").Value
CHUAN = Range("D7:N9").Value
GT = Range("D11:N13").Value
BT = Range("D15:N17").Value
MGT = Range("D19:N21").Value
MBT = Range("D23:N25").Value
QT = Range("D27:N29").Value
KT = Range("D31:N33").Value
arr = Range("W14").Value
For i = 1 To 11
    For j = 1 To 3
        For k = 1 To 4
            If Ngay(1, i) = Range("T14").Value Then
             
                For Each range1 In Range("A8:A32")
                        If range1.Value = Range("W14").Value Then                            ' xac dinh Group
                            row1 = range1.Row
                            col1 = range1.Column
                            Arr8 = Range(Cells(row1 - 1, 4), Cells(row1 + 1, 14)).Value  ' Xac dinh mang Group
                                If CHUAN(j, i) = Range("V14").Value Then                         'xác dinh Ca
                                    Arr8(j, i) = Range("U14").Value                                      ' add Name
                                    Range(Cells(row1 - 1, 4), Cells(row1 + 1, 14)).Value = Arr8

                                End If
                        End If
                Next range1
            End If


        Next k
    Next j

Next i
MsgBox ("Done")
End Sub
 

File đính kèm

Upvote 0
snow25 đã viết:
Đây bạn xem.Có đúng không nhé.
Mã: 
Sub doiulieu()
Dim arr, arr1, dic As Object, i As Long, lr As Long, j As Long, dk As String, dks As String, b As Long, c As Long, d As Long
Set dic = CreateObject("scripting.dictionary")
With Sheet1
     arr = .Range("D5:n9").Value
     For j = 1 To UBound(arr, 2)
         For i = 3 To UBound(arr, 1)
             dk = CLng(arr(1, j)) & "#" & arr(i, j)
             If Not dic.exists(dk) Then
                dic.Item(dk) = Array(i - 4, j)
             End If
         Next i
     Next j
     lr = .Range("D" & Rows.Count).End(xlUp).Row
     If lr < 11 Then Exit Sub
     arr = .Range("a11:N" & lr).Value
     For i = 1 To UBound(arr, 1)
         If Len(arr(i, 1)) > 0 Then
            If Not dic.exists(arr(i, 1)) Then
               dic.Add arr(i, 1), i
            End If
         End If
     Next i
     dk = CLng(.Range("T14").Value) & "#" & .Range("V14").Value
     dks = .Range("W14").Value
     If dic.exists(dk) Then
           b = dic.Item(dk)(0)
           c = dic.Item(dk)(1)
         If dic.exists(dks) Then
            d = dic.Item(dks)
            arr(b + d, c + 3) = .Range("u14").value
           End If
      End If
      .Range("a11:N" & lr).Value = arr
End With
End Sub
Nhấp chuột vào đây để mở rộng...

Em có chỗ muốn hỏi! Mong anh giúp!
1.> Em giải nghĩa đoan code dưới các anh xem giúp em thế có đúng không ạ!

Mã: 
dk = CLng(arr(1, j)) & "#" & arr(i, j)

             If Not dic.exists(dk) Then                         ' 

                dic.Item(dk) = Array(i - 4, j)

             End If

Em hiểu đoạn code trên là:
- Xét xem có key "dk" chưa nếu chưa thì gán cho key "dk" một item mảng: Array(i-4,j)
- Để xác định vị trí của key "dk "ta dùng :
b = dic.Item(dk)(0) ' b: là giá trị của chiều thứ 1
c = dic.Item(dk)(1) ' c: là giá trị của chiều thứ 2
- Đôi với key "dks" item là một biến i nên để xác định ta dùng:
d = dic.Item(dks)

2.> Sao ta không dùng dấu "&" mà lại dùng dấu "#" ở đây: dk = CLng(arr(1, j)) & "#" & arr(i, j)
Có sự khác biệt gì không ạ!

Em cảm ơn các anh nhiều!
 
Upvote 0
HieuCD đã viết:
Dic thường dùng lưu dữ liệu và truy xuất nhiều lần, bài nầy chỉ tìm 1 lần, dùng Dic khá lãng phí, thử bỏ Dic code sẽ gọn và nhanh hơn
Trong code nên thêm phần thông báo không đổi được do trong ngày, nhóm đó không có ca tương ứng ;)
Nhấp chuột vào đây để mở rộng...
Vậy bảo bạn đó là dữ liệu có thể thay thế nhiều lần cùng 1 lúc.Hihi.Cảm ơn anh nhé.
Bài đã được tự động gộp:

alias1313 đã viết:
Em có chỗ muốn hỏi! Mong anh giúp!
1.> Em giải nghĩa đoan code dưới các anh xem giúp em thế có đúng không ạ!

Mã: 
dk = CLng(arr(1, j)) & "#" & arr(i, j)

             If Not dic.exists(dk) Then                         '

                dic.Item(dk) = Array(i - 4, j)

             End If

Em hiểu đoạn code trên là:
- Xét xem có key "dk" chưa nếu chưa thì gán cho key "dk" một item mảng: Array(i-4,j)
- Để xác định vị trí của key "dk "ta dùng :
b = dic.Item(dk)(0) ' b: là giá trị của chiều thứ 1
c = dic.Item(dk)(1) ' c: là giá trị của chiều thứ 2
- Đôi với key "dks" item là một biến i nên để xác định ta dùng:
d = dic.Item(dks)

2.> Sao ta không dùng dấu "&" mà lại dùng dấu "#" ở đây: dk = CLng(arr(1, j)) & "#" & arr(i, j)
Có sự khác biệt gì không ạ!

Em cảm ơn các anh nhiều!
Nhấp chuột vào đây để mở rộng...
Dùng cái gì phân cách cũng được nhé bạn.Miễn là nó ko bị trùng.
 
Upvote 0
HieuCD đã viết:
Dic thường dùng lưu dữ liệu và truy xuất nhiều lần, bài nầy chỉ tìm 1 lần, dùng Dic khá lãng phí, thử bỏ Dic code sẽ gọn và nhanh hơn
Trong code nên thêm phần thông báo không đổi được do trong ngày, nhóm đó không có ca tương ứng ;)
Nhấp chuột vào đây để mở rộng...
Anh xem có đúng không nhé.
Mã: 
Sub doiulieu()
Dim arr, arr1, dic As Object, i As Long, lr As Long, j As Integer, dk As Long, dks As String, b As Long, c As Long, d As Long
With Sheet1
     arr = .Range("D5:n9").Value
     lr = .Range("D" & Rows.Count).End(xlUp).Row
     If lr < 11 Then Exit Sub
     arr1 = .Range("a11:N" & lr).Value
     For i = 1 To UBound(arr, 2)
         If CLng(arr(1, i)) = CLng(.Range("T14")) Then
            For j = 3 To UBound(arr, 1)
                If UCase(arr(j, i)) = UCase(.Range("V14").Value) Then
                   For k = 1 To UBound(arr1, 1)
                       If UCase(arr1(k, 1)) = UCase(.Range("W14").Value) Then
                                arr1(j - 4 + k, i + 3) = .Range("U14").Value
                                dk = 1
                                Exit For
                       End If
                   Next k
                   Exit For
                End If
           Next j
           Exit For
        End If
    Next i
    If dk = 1 Then
      .Range("a11:N" & lr).Value = arr1
      MsgBox "da sua du lieu"
    Else
      MsgBox "khong tim thay"
   End If
End With
End Sub
 
Upvote 0
snow25 đã viết:
Anh xem có đúng không nhé.
Mã: 
Sub doiulieu()
Dim arr, arr1, dic As Object, i As Long, lr As Long, j As Integer, dk As Long, dks As String, b As Long, c As Long, d As Long
With Sheet1
     arr = .Range("D5:n9").Value
     lr = .Range("D" & Rows.Count).End(xlUp).Row
     If lr < 11 Then Exit Sub
     arr1 = .Range("a11:N" & lr).Value
     For i = 1 To UBound(arr, 2)
         If CLng(arr(1, i)) = CLng(.Range("T14")) Then
            For j = 3 To UBound(arr, 1)
                If UCase(arr(j, i)) = UCase(.Range("V14").Value) Then
                   For k = 1 To UBound(arr1, 1)
                       If UCase(arr1(k, 1)) = UCase(.Range("W14").Value) Then
                                arr1(j - 4 + k, i + 3) = .Range("U14").Value
                                dk = 1
                                Exit For
                       End If
                   Next k
                   Exit For
                End If
           Next j
           Exit For
        End If
    Next i
    If dk = 1 Then
      .Range("a11:N" & lr).Value = arr1
      MsgBox "da sua du lieu"
    Else
      MsgBox "khong tim thay"
   End If
End With
End Sub
Nhấp chuột vào đây để mở rộng...
Hay quá anh! Cảm ơn anh nhiều!
 
Upvote 0

File đính kèm

Upvote 0
Em có một vấn đề mong các anh giải đáp giúp em!
Em có một vùng dữ liệu: Range(“B1:C10”) và em có hai cách xử lý:
-Cách 1:
Mã: 
2.>    Theo Range:
Sub Test()
Dim range1 as range
For each range1 in Range(“B1:C10”)
    If range1.value = “ CAM ON GPE” then
                   Row1 = range1.row
                   Col1 = range1.column
    End if
Next range1
End sub

- Cách 2:

Mã: 
Sub Test()
Dim Arr as variant
Arr = Range(“B1:D10”).value
For i = 1 to 10
       For j = 1 to 3
             If Arr( i,j) = “ CAM ON GPE” then
                    ‘  Row1= ?
                    ‘ Col1 = ?
            End if
       Next j
Next i
End sub
Vấn đề em muốn hỏi:
- Ở cách 1 khi xác định được range1 em có thể xác định được: Row1/Col1
- Em có thể tìm được Row1/Col1 bằng cách 2 không ạ? Mảng có cho ta tìm row/col như range không ạ?, ( không tính việc tìm bằng thủ công ạ)

Em cảm ơn!
 
Lần chỉnh sửa cuối:
Upvote 0
snow25 đã viết:
Anh xem có đúng không nhé.
Mã: 
Sub doiulieu()
Dim arr, arr1, dic As Object, i As Long, lr As Long, j As Integer, dk As Long, dks As String, b As Long, c As Long, d As Long
With Sheet1
     arr = .Range("D5:n9").Value
     lr = .Range("D" & Rows.Count).End(xlUp).Row
     If lr < 11 Then Exit Sub
     arr1 = .Range("a11:N" & lr).Value
     For i = 1 To UBound(arr, 2)
         If CLng(arr(1, i)) = CLng(.Range("T14")) Then
            For j = 3 To UBound(arr, 1)
                If UCase(arr(j, i)) = UCase(.Range("V14").Value) Then
                   For k = 1 To UBound(arr1, 1)
                       If UCase(arr1(k, 1)) = UCase(.Range("W14").Value) Then
                                arr1(j - 4 + k, i + 3) = .Range("U14").Value
                                dk = 1
                                Exit For
                       End If
                   Next k
                   Exit For
                End If
           Next j
           Exit For
        End If
    Next i
    If dk = 1 Then
      .Range("a11:N" & lr).Value = arr1
      MsgBox "da sua du lieu"
    Else
      MsgBox "khong tim thay"
   End If
End With
End Sub
Nhấp chuột vào đây để mở rộng...
Hay lắm, code rất tường minh /-*+/
Dùng 3 Exit For hơi "sang trọng", thay bằng 1 Exit Sub sẽ gọn hơn nhiều :)
Bài đã được tự động gộp:

alias1313 đã viết:
Em có một vấn đề mong các anh giải đáp giúp em!
Em có một vùng dữ liệu: Range(“B1:C10”) và em có hai cách xử lý:
-Cách 1:
Mã: 
2.>    Theo Range:
Sub Test()
Dim range1 as range
For each range1 in Range(“B1:C10”)
    If range1.value = “ CAM ON GPE” then
                   Row1 = range1.row
                   Col1 = range1.column
    End if
Next range1
End sub

- Cách 2:

Mã: 
Sub Test()
Dim Arr as variant
Arr = Range(“B1:D10”).value
For i = 1 to 10
       For j = 1 to 3
             If Arr( i,j) = “ CAM ON GPE” then
                    ‘  Row1= ?
                    ‘ Col1 = ?
            End if
       Next j
Next i
End sub
Vấn đề em muốn hỏi:
- Ở cách 1 khi xác định được range1 em có thể xác định được: Row1/Col1
- Em có thể tìm được Row1/Col1 bằng cách 2 không ạ? Mảng có cho ta tìm row/col như range không ạ?, ( không tính việc tìm bằng thủ công ạ)

Em cảm ơn!
Nhấp chuột vào đây để mở rộng...
Mã: 
Sub Test()
Dim Arr as variant
Arr = Range(“B1:D10”).value
fRow = Range(“B1:D10”).Row
fCol = Range(“B1:D10”).Column
For i = 1 to 10
       For j = 1 to 3
             If Arr( i,j) = “ CAM ON GPE” then
                    Row1= i + fRow - 1
                    Col1 = j + fCol - 1
            End if
       Next j
Next i
End sub
 
Lần chỉnh sửa cuối:
Upvote 0
HieuCD đã viết:
Hay lắm, code rất tường minh /-*+/
Dùng 3 Exit For hơi "sang trọng", thay bằng 1 Exit Sub sẽ gọn hơn nhiều :)
Bài đã được tự động gộp:


Mã: 
Sub Test()
Dim Arr as variant
Arr = Range(“B1:D10”).value
fRow = Range(“B1:D10”).Row
fCol = Range(“B1:D10”).Column
For i = 1 to 10
       For j = 1 to 3
             If Arr( i,j) = “ CAM ON GPE” then
                    Row1= i + fRow - 1
                    Col1 = j + fCol - 1
            End if
       Next j
Next i
End sub
Nhấp chuột vào đây để mở rộng...
Đây là thắc mắc em đã tìm rất lâu mà chưa tìm ra! haha!
Giờ em mới biết có công thức cho tìm Row/col đầu tiên của Range().
Cảm ơn anh @HieuCD rất nhiều! ^_^!
 
Upvote 0
A Đặng đã viết:
Dear Anh/ Chin trong topic.
Mọi người giúp em làm sao để kiểm tra một giá trị trong mảng.?
Giống dạng hàm in_array trong php của bên này https://cuongquach.com/kiem-tra-mot-gia-tri-mang-arrray-in_array-php.html
Liệu trong VBA có cách nào được như thế không ạ?
Cám ơn !
Nhấp chuột vào đây để mở rộng...
Cái này bạn phải viết 1 Function để kiểm tra nó có tồn tại hay không? VB không như Php không có những hàm đó
 
Upvote 0
Upvote 0
tam888 đã viết:
tìm hiểu ArrayList trong VBA là được, search trên GPE cũng có bài nói về đối tượng này
Nhấp chuột vào đây để mở rộng...
Theo e nghĩ vốn dĩ mình đã tạo một Array rồi, vì chỉ cần kiểm tra một giá trị trong array đó mà lại phải tạo thêm một ArrayList nữa thì có hơi bất cập quá không ?
Bthuong e dùng For duyệt qua các giá trị của Array vẫn đạt được kết quả, tuy nhiên với giá trị của Array nhiều nên muốn tham khảo một phương pháp dạng giống như Find hay Exist chẳng hạn để giảm bớt thủ tục.
Anh góp ý thêm ạ !
 
Upvote 0
A Đặng đã viết:
Theo e nghĩ vốn dĩ mình đã tạo một Array rồi, vì chỉ cần kiểm tra một giá trị trong array đó mà lại phải tạo thêm một ArrayList nữa thì có hơi bất cập quá không ?
Bthuong e dùng For duyệt qua các giá trị của Array vẫn đạt được kết quả, tuy nhiên với giá trị của Array nhiều nên muốn tham khảo một phương pháp dạng giống như Find hay Exist chẳng hạn để giảm bớt thủ tục.
Anh góp ý thêm ạ !
Nhấp chuột vào đây để mở rộng...
Uhm, nếu muốn tìm hiểu thuật toán thì có thể tự viết - tìm hiểu các thuật toán tìm kiếm nhanh (duyệt cũng là 1 cách cơ bản và chậm, duyệt dạng nhị phân -thuật toán chia đôi, ...vv)
Muốn dùng công cụ nhanh gọn thì tìm hiểu ARRAYLIST - nó cũng là array, hay DICTIONARY, tùy bạn thôi, Lập trình là do ta chọn con đường
Find hay Exist - thì gốc người ta cũng phải viết code tìm kiếm thôi
 
Lần chỉnh sửa cuối:
Upvote 0
A Đặng đã viết:
Dear Anh/ Chin trong topic.
Mọi người giúp em làm sao để kiểm tra một giá trị trong mảng.?
Giống dạng hàm in_array trong php của bên này https://cuongquach.com/kiem-tra-mot-gia-tri-mang-arrray-in_array-php.html
Liệu trong VBA có cách nào được như thế không ạ?
Cám ơn !
Nhấp chuột vào đây để mở rộng...
Chỉ xét mảng Arr 1 dòng hoặc 1 cột
Mảng 1 chiều
InStr(1, "#" & Join(Arr, "#") & "#", "#" & BienX & "#") > 0
Mảng 2 chiều
InStr(1, "#" & Join(Application.Transpose(Arr), "#") & "#", "#" & BienX & "#") > 0
 
Upvote 0
A Đặng đã viết:
Em thấy hoang mang quá Anh
Nhấp chuột vào đây để mở rộng...
Nếu bạn học lập trình thì trong quá trình học, có môn cấu trúc dữ liệu, cái môn này nó chỉ cho bạn các kỹ thuật sắp xếp và tìm kiếm, bạn có thể vận dụng nó mà làm, bạn có thể chọn bất cứ thuật toán nào thuận tiện cho bạn cũng được, hiện tại máy tính mạnh và bạn không ứng dụng số liệu lớn nên có thể tìm thuật toán nào đó đơn giản để áp dụng vào, không có gì hoang mang đâu bạn
 
Upvote 0
HieuCD đã viết:
Chỉ xét mảng Arr 1 dòng hoặc 1 cột
Mảng 1 chiều
InStr(1, "#" & Join(Arr, "#") & "#", "#" & BienX & "#") > 0
Mảng 2 chiều
InStr(1, "#" & Join(Application.Transpose(Arr), "#") & "#", "#" & BienX & "#") > 0
Nhấp chuột vào đây để mở rộng...
Mảng 1 chiều thì chỉ cần dùng hàm Application.Match
 
Upvote 0
Em chào anh/chị ạ.

Em là thành viên mới, em bây giờ mới tập tành về code, nên mạn phép lên đây nhờ anh/chị chỉ giáo em đôi chút ạ.
Em không biết nhấn vào đâu để viết câu hỏi mới, nên đành phải gửi qua hình thức trả lời bình luận của anh/chị trong topic :((
Hiện tại em có học trên mạng 1 dãy code "Gộp nhiều sheet excel vào chung 1 sheet", nhưng trong phần code này lại chỉ viết RangeAddress đối với các sheet có số cột và số dòng giống nhau, chứ không có code áp dụng đối với các sheet có số dòng khác nhau (2000 dòng; 3000 dòng hoặc 4000 dòng thì sao ạ?)
Anh/chị chỉ giúp em code đối với đề bài "Gộp nhiều sheet excel vào chung 1 sheet cùng form, số dòng khác nhau" với ạ. Em cảm ơn nhiều.

Bài viết đầu có hơi lủng củng, mong anh/chị thông cảm ạ.Capture.PNG
 
Upvote 0
Tiểu Mộc Mộc đã viết:
Em chào anh/chị ạ.

Em là thành viên mới, em bây giờ mới tập tành về code, nên mạn phép lên đây nhờ anh/chị chỉ giáo em đôi chút ạ.
Em không biết nhấn vào đâu để viết câu hỏi mới, nên đành phải gửi qua hình thức trả lời bình luận của anh/chị trong topic :((
Hiện tại em có học trên mạng 1 dãy code "Gộp nhiều sheet excel vào chung 1 sheet", nhưng trong phần code này lại chỉ viết RangeAddress đối với các sheet có số cột và số dòng giống nhau, chứ không có code áp dụng đối với các sheet có số dòng khác nhau (2000 dòng; 3000 dòng hoặc 4000 dòng thì sao ạ?)
Anh/chị chỉ giúp em code đối với đề bài "Gộp nhiều sheet excel vào chung 1 sheet cùng form, số dòng khác nhau" với ạ. Em cảm ơn nhiều.

Bài viết đầu có hơi lủng củng, mong anh/chị thông cảm ạ.View attachment 212451
Nhấp chuột vào đây để mở rộng...
Khai báo địa chỉ lớn nhất như 10000 dòng
Select thêm điều kiện Where f1 is not null vào cuối
 
Upvote 0
HieuCD đã viết:
Khai báo địa chỉ lớn nhất như 10000 dòng
Select thêm điều kiện Where f1 is not null vào cuối
Nhấp chuột vào đây để mở rộng...
Cho em hỏi, em viết như thế này đúng không ạ?

Dim cnn As ADODB.Connection
Dim rst As ADODB.Recordset
Dim sh As Worksheet
Dim I As Long, k As Long, CountFiles As Long, J As Long

SheetName = "Platium" & "$"
RangeAddress = "A12:AD1000" Where f1 is not null

Dim files As Variant
files = Application.GetOpenFilename(, , , , True)

If VarType(files) = vbBoolean Then Exit Sub

Set sh = Sheets("Sheet1")
 
Upvote 0
Tiểu Mộc Mộc đã viết:
Cho em hỏi, em viết như thế này đúng không ạ?

Dim cnn As ADODB.Connection
Dim rst As ADODB.Recordset
Dim sh As Worksheet
Dim I As Long, k As Long, CountFiles As Long, J As Long

SheetName = "Platium" & "$"
RangeAddress = "A12:AD1000" Where f1 is not null

Dim files As Variant
files = Application.GetOpenFilename(, , , , True)

If VarType(files) = vbBoolean Then Exit Sub

Set sh = Sheets("Sheet1")
Nhấp chuột vào đây để mở rộng...
Thêm: & " Where f1 is not null" vào sau "]" của Set rst
 
Upvote 0
HeSanbi đã viết:
Thêm: & " Where f1 is not null" vào sau "]" của Set rst
Nhấp chuột vào đây để mở rộng...
A ơi. Xin lỗi cho em làm phiền chút ạ.

Bài trên em có hỏi về code VBA về "cách gộp nhiều sheet tách biệt vào chung 1 sheet duy nhất", đối với các file có nhiều sheet và có số dòng khác nhau ạ.

Em thấy trên mạng có code này, nhưng em thử đi thử lại không chạy được, không biết bị lỗi gì ạ???

Em có 3 file dữ liệu: AB,ABB và ABBB, và em muốn gộp dữ liệu của sheet name "Hoa" của 3 file đó vào 1 sheet "Master" của file Test.

Em gửi anh đính kèm file và code em chạy, anh có thể xem giúp em lỗi code ở đâu với ạ.

Em cảm ơn anh nhiều.Capture.PNG
 

File đính kèm

Upvote 0
Tiểu Mộc Mộc đã viết:
Sau khi em tick 1 loạt Microsoft ActiveX Data Objects x.x Library

Vẫn hiện ra lỗi này ạ.
Nhấp chuột vào đây để mở rộng...
Bạn copy Code của ai thì phải Copy toàn bộ code hoặc tải file người đấy đăng. Không thì các hàm tự tạo trong code lấy đâu mà nó chạy được.
Không thì bạn học VBA ngay thôi
 
Upvote 0
HeSanbi đã viết:
Bạn Vào Tools , Vào References ... , Tìm Microsoft ActiveX Data Objects x.x Library đánh dấu
Nhấp chuột vào đây để mở rộng...
Bấm xong nó hiện ra ntn ạ.
1550725144843.png
1550725113040.png
Bài đã được tự động gộp:

HeSanbi đã viết:
Bạn copy Code của ai thì phải Copy toàn bộ code hoặc tải file người đấy đăng. Không thì các hàm tự tạo trong code lấy đâu mà nó chạy được.
Không thì bạn học VBA ngay thôi
Nhấp chuột vào đây để mở rộng...
Em copy toàn bộ code của ng đó rồi ạ. Nhưng không có file để tải nên em tự tạo file để áp dụng ấy ạ.
 
Upvote 0
Upvote 0
Xin chào các bạn,
OT có một vấn đề sau chưa biết cách xử lý, nhờ các bạn xem và giúp đỡ ạ.
 

File đính kèm

Upvote 0
snow25 đã viết:
Có quy luật gì không ta.Hay cứ lấy hên sui.
Nhấp chuột vào đây để mở rộng...
Qui luật là bí mật quốc gia. Nhìn kết quả mong đợi rồi đoán thôi. :D

Vd. bắn lên. Ta đã có thông tin là dòng dưới bắn lên trên (lần này súng bắn một chiều). Nhưng bắn cả dòng dưới lên hay chỉ bắn những ô có dữ liệu của dòng dưới lên? Tôi cho vd.

Giả sử G10 = G11 = hichic. Sau khi bắn thì
- Z10 = 55, Z11 = 600, G10 = G11 = rỗng do G12 = G13 = rỗng bắn lên (bắn cả dòng dưới lên, ghi đè)
- Z10 = 55, Z11 = 600, G10 = G11 = hichic (chỉ bắn các ô <> rỗng của dòng dưới lên trên)

Trường hợp nào đây?

Nếu chỉ bắn các ô <> rỗng của dòng dưới lên trên thì cũng lại có câu hỏi: thế nếu ô tương ứng ở dòng trên đã <> rỗng thì có bắn vào các ô ấy không hay bỏ qua?

Thế nếu có 3 dòng cùng mã thì dòng 3 chỉ bắn lên dòng 2 hay bắn cả lên tới dòng 1?

Tóm lại kết quả mong đợi chỉ là bổ sung cho mô tả. Không thể lấy kết quả mong đợi thay thế cho mô tả khi vấn đề có thể hiểu theo nhiều kiểu.
 
Upvote 0
Nguyễn Hoàng Oanh Thơ đã viết:
Cảm ơn snow25 đã quan tâm,
Quy luật là copy ở dưới đưa lên cái trên và đưa vào những mã giống nhau ạ.
Nhấp chuột vào đây để mở rộng...
Bạn xem nhé.
Mã: 
Sub laydulieu()
    Dim arr, i As Long, dic As Object, a As Long, b As Long, dk As Long, k As Long, j As Long
    Set dic = CreateObject("scripting.dictionary")
    With Sheet1
        arr = .Range("E4:z25").Value
        For i = 1 To UBound(arr, 1) Step 2
            For j = 3 To UBound(arr, 2)
                If Len(arr(i, j)) > 0 Then
                   dic.Item(arr(i, 1)) = i
                   Exit For
                End If
            Next j
        Next i
        For i = 1 To UBound(arr, 1) Step 2
            a = dic.Item(arr(i, 1))
               If a And a <> i Then
                 For k = 0 To 1
                  For j = 3 To UBound(arr, 1)
                      arr(i + k, j) = arr(a + k, j)
                  Next j
                 Next k
               End If
       Next i
       .Range("Ac4:Ax25").Value = arr
   End With
 
Upvote 0
Cảm ơn Bác Siwtom và Snow25 đã giúp đỡ.
Đúng như Bác Siwtom đã góp ý bài này có rất nhiều lúc ngược lúc xuôi lúc 2 mã, lúc 3 mã giống nhau... rất nhiều điều kiện (khá rắc rối)
Vì vậy mà OT đã chọn hướng đi khác đi khác rồi ạ.
Chúc Bác & Bạn nhiều sức khỏe.
 
Upvote 0
Xin chào các bạn,
Nhờ các bạn giúp OT đỡ trường hợp trong tập tin gửi kèm với ạ.
 

File đính kèm

Upvote 0
Nguyễn Hoàng Oanh Thơ đã viết:
Xin chào các bạn,
Nhờ các bạn giúp OT đỡ trường hợp trong tập tin gửi kèm với ạ.
Nhấp chuột vào đây để mở rộng...
Bạn chạy thử sub này nhé.
Mã: 
Sub chuyen()
Dim arr, arr1, lr As Long, i As Long, a As Long, j As Long
With Sheet1
    lr = .Range("D" & Rows.Count).End(xlUp).Row
    arr = .Range("D3:aj" & lr).Value
    ReDim arr1(1 To UBound(arr, 1) * 31, 1 To 4)
End With
   For i = 1 To UBound(arr, 1)
       For j = 3 To UBound(arr, 2)
           If arr(i, j) <> Empty Then
              a = a + 1
              arr1(a, 1) = arr(i, 1)
              arr1(a, 2) = arr(i, 2)
              arr1(a, 3) = j - 2
              arr1(a, 4) = arr(i, j)
           End If
       Next j
   Next i
With Sheet2
      lr = .Range("C" & Rows.Count).End(xlUp).Row
      If lr > 2 Then .Range("C3:F" & lr).ClearContents
      If a Then .Range("c3").Resize(a, 4).Value = arr1
End With
End Sub
 
Upvote 0
snow25 đã viết:
Bạn chạy thử sub này nhé.
Mã: 
Sub chuyen()
Dim arr, arr1, lr As Long, i As Long, a As Long, j As Long
With Sheet1
    lr = .Range("D" & Rows.Count).End(xlUp).Row
    arr = .Range("D3:aj" & lr).Value
    ReDim arr1(1 To UBound(arr, 1) * 31, 1 To 4)
End With
   For i = 1 To UBound(arr, 1)
       For j = 3 To UBound(arr, 2)
           If arr(i, j) <> Empty Then
              a = a + 1
              arr1(a, 1) = arr(i, 1)
              arr1(a, 2) = arr(i, 2)
              arr1(a, 3) = j - 2
              arr1(a, 4) = arr(i, j)
           End If
       Next j
   Next i
With Sheet2
      lr = .Range("C" & Rows.Count).End(xlUp).Row
      If lr > 2 Then .Range("C3:F" & lr).ClearContents
      If a Then .Range("c3").Resize(a, 4).Value = arr1
End With
End Sub
Nhấp chuột vào đây để mở rộng...
Xin cảm ơn Snow25 rất nhiều, kết quả đúng ý OT rồi ạ.
 
Upvote 0
Với bài toán này các anh xem giúp dùng mảng có trị được không ạ
Hiện em đang phải thực hiện các bước sau để đưa dữ liệu vào 2 Sheet
1. Lấy thủ công số phiếu, ngày xuất vật tư đưa vào Sheet Input_TB cột AS, AT, AU
2. Lấy số lượng, đơn giá vật tư đưa vào Sheet Input_TB theo bảng
3. Căn cứ vào vật tư đã lấy vào Sheet Input_TB đưa sang Sheet BQT_VTU
+ Nếu xuất hiện bao nhiêu lần trong phiếu xuất sẽ có bấy nhiêu dòng bên BQT_VTU
+ Lấy số phiếu, số lượng vật tư, đơn giá tương ứng từ Sheet Input_TB qua Sheet BQT_VTU

Topic nhờ giúp
 

File đính kèm

Upvote 0
Em có viết 1 đoạn VBA để tổng hợp bảng kê ra bảng tổng hợp tuy nhiên code sử dụng lại chạy chưa đúng !. anh (chị) sửa lỗi sai giúp em với ạ !
Mã: 
Sub TongHop2()
 Dim Data As Variant, Arr(1 To 65536, 1 To 6), i As Long, TenKh As String, j As Long, k As Long
 Data = Sheet2.Range("A2:F15").Value
 If UBound(Data) = 1 Then Exit Sub
    For i = 1 To UBound(Data)
   If Data(i, 1) = "Tên KH" Then TenKh = Data(i, 2)
    If TypeName(Data(i, 1)) = "Double" Then
      k = k + 1
      Arr(k, 1) = TenKh
      Arr(k, 2) = Data(i + 1, 1)
      Arr(k, 3) = Data(i + 1, 2)
      Arr(k, 4) = Data(i + 1, 3)
      Arr(k, 5) = Data(i + 1, 4)
      Arr(k, 6) = Data(i + 1, 5)
    End If
    Next
If k Then Sheet2.Range("H2").Resize(k, 6).Value = Arr
End Sub
 

File đính kèm

Upvote 0
vanvan9697 đã viết:
Em có viết 1 đoạn VBA để tổng hợp bảng kê ra bảng tổng hợp tuy nhiên code sử dụng lại chạy chưa đúng !. anh (chị) sửa lỗi sai giúp em với ạ !
Mã: 
Sub TongHop2()
Dim Data As Variant, Arr(1 To 65536, 1 To 6), i As Long, TenKh As String, j As Long, k As Long
Data = Sheet2.Range("A2:F15").Value
If UBound(Data) = 1 Then Exit Sub
    For i = 1 To UBound(Data)
   If Data(i, 1) = "Tên KH" Then TenKh = Data(i, 2)
    If TypeName(Data(i, 1)) = "Double" Then
      k = k + 1
      Arr(k, 1) = TenKh
      Arr(k, 2) = Data(i + 1, 1)
      Arr(k, 3) = Data(i + 1, 2)
      Arr(k, 4) = Data(i + 1, 3)
      Arr(k, 5) = Data(i + 1, 4)
      Arr(k, 6) = Data(i + 1, 5)
    End If
    Next
If k Then Sheet2.Range("H2").Resize(k, 6).Value = Arr
End Sub
Nhấp chuột vào đây để mở rộng...
Bạn xem file đính kèm
Mã: 
Sub TongHop2()
Dim Data(), Arr(), i As Long, TenKh As String, j As Long, k As Long
Data = Sheet2.Range("A2:F15").Value
ReDim Arr(1 To UBound(Data, 1), 1 To 7)
    For i = 1 To UBound(Data)
        If Data(i, 1) = "Tên KH" Then TenKh = Data(i, 2)
        If IsDate(Data(i, 1)) Then
            k = k + 1
            Arr(k, 1) = TenKh
            For j = 1 To 6
                Arr(k, j + 1) = Data(i, j)
            Next j
        End If
    Next i
If k Then
    Sheet2.Range("H2").Resize(1000, 7).ClearContents
    Sheet2.Range("H2").Resize(k, 7).Value = Arr
End If
End Sub
 

File đính kèm

Upvote 0
leonguyenz đã viết:
Bạn xem file đính kèm
Mã: 
Sub TongHop2()
Dim Data(), Arr(), i As Long, TenKh As String, j As Long, k As Long
Data = Sheet2.Range("A2:F15").Value
ReDim Arr(1 To UBound(Data, 1), 1 To 7)
    For i = 1 To UBound(Data)
        If Data(i, 1) = "Tên KH" Then TenKh = Data(i, 2)
        If IsDate(Data(i, 1)) Then
            k = k + 1
            Arr(k, 1) = TenKh
            For j = 1 To 6
                Arr(k, j + 1) = Data(i, j)
            Next j
        End If
    Next i
If k Then
    Sheet2.Range("H2").Resize(1000, 7).ClearContents
    Sheet2.Range("H2").Resize(k, 7).Value = Arr
End If
End Sub
Nhấp chuột vào đây để mở rộng...
Dạ em cảm ơn anh ạ !
 
Upvote 0
Các bạn chưa xóa dữ liệu trong lần chạy trước
Nếu trường hợp làn chạy sau có chỉ số K bé hơn lần trước thì kết quả sẽ là trời ơi!
 
Upvote 0
Với câu lệnh này
If k Then Sheet2.Range("H2").Resize(k, 6).Value = Arr
Thì có thể có 2 trương hợp sẩy ra:

(1) Lần chạy macro lần trước K=9 (giả dụ)
Lần này chỉ có K=7
Vậy thì 2 dòng dữ liệu của lần chạy trước còn nguyên xi & bạn sẽ vẫn tưởng kết quả của macro đem lại vẫn 9 dòng dữ liệu, thay vì 7

(2) Nếu lần chạy macro sau có số dòng bằng hoặc lớn hơn lần chạy trước thì bạn đã tiết kiệm được 1 dòng lệnh & không đán để được chúc mừng đâu!
 
Upvote 0
SA_DQ đã viết:
Với câu lệnh này
If k Then Sheet2.Range("H2").Resize(k, 6).Value = Arr
Thì có thể có 2 trương hợp sẩy ra:

(1) Lần chạy macro lần trước K=9 (giả dụ)
Lần này chỉ có K=7
Vậy thì 2 dòng dữ liệu của lần chạy trước còn nguyên xi & bạn sẽ vẫn tưởng kết quả của macro đem lại vẫn 9 dòng dữ liệu, thay vì 7

(2) Nếu lần chạy macro sau có số dòng bằng hoặc lớn hơn lần chạy trước thì bạn đã tiết kiệm được 1 dòng lệnh & không đán để được chúc mừng đâu!
Nhấp chuột vào đây để mở rộng...
Vậy có nghĩa là trước khi ghi dữ liệu sẽ xóa đi rồi câu lệnh đó là k >0 đúng không anh !
 
Upvote 0
SA_DQ đã viết:
Các bạn chưa xóa dữ liệu trong lần chạy trước
...
(1) Lần chạy macro lần trước K=9 (giả dụ)
Lần này chỉ có K=7
Vậy thì 2 dòng dữ liệu của lần chạy trước còn nguyên xi & bạn sẽ vẫn tưởng kết quả của macro đem lại vẫn 9 dòng dữ liệu, thay vì 7
Nhấp chuột vào đây để mở rộng...
Cái này không đúng. Vì nếu k = 7 thì có nghĩa là k > 0, tức dòng
Mã: 
Sheet2.Range("H2").Resize(1000, 7).ClearContents
sẽ được thực hiện nên không có chuyện "bạn sẽ vẫn tưởng kết quả của macro đem lại vẫn 9 dòng dữ liệu". Dòng trên là của leonguyenz mà bạn viết
Các bạn chưa xóa dữ liệu trong lần chạy trước
Nhấp chuột vào đây để mở rộng...
thì không đúng.

Tất nhiên phải xóa dữ liệu cũ nhưng lý do không phải là "Nếu trường hợp làn chạy sau có chỉ số K bé hơn lần trước thì kết quả sẽ là trời ơi!" mà là "Nếu trường hợp làn chạy sau có chỉ số K = 0 thì kết quả sẽ là trời ơi!". Tại sao? Vì khi k = 0 thì lẽ ra phải là không có kết quả nhưng do k = 0 nên code trong If k Then ... End If của leonguyenz không được thực hiện nên kết quả cũ không được xóa, và người ta hiểu lầm là vẫn có kết quả.

Code của leonguyenz có xóa kết quả cũ nhưng chưa chuẩn vì chỉ xóa khi k > 0 mà không xóa khi k = 0.

Lôgíc là: trước hết xóa kết quả cũ sau đó chạy code còn lại. Nếu sau đó không có dữ liệu thỏa điều kiện thì ắt hẳn k = 0 và lúc đó "vùng kết quả trắng tinh" (do trước đó vùng kết quả đã được xóa). Nếu sau đó k > 0 thì kết quả có bao nhiêu thì sẽ được nhập vào vùng kết quả bấy nhiêu, không thừa và cũng không thiếu, vừa vặn.

Tóm lại trong code của leonguyenz
- xóa dòng
Mã: 
Sheet2.Range("H2").Resize(1000, 7).ClearContents

- trước dòng
Mã: 
Data = Sheet2.Range("A2:F15").Value
thì thêm dòng
Mã: 
Sheet2.Range("H2").Resize(1000, 7).ClearContents

Nói cách khác: hãy chuyển dòng
Mã: 
Sheet2.Range("H2").Resize(1000, 7).ClearContents
lên đầu.

Nếu dữ liệu rất nhiều và có khả năng kết quả > 1000 thì sửa 1000 thành số "đủ lớn". Hoặc xác định dòng cuối cùng trong vùng kết quả cũ để xóa hết kết quả cũ.
 
Lần chỉnh sửa cuối:
Upvote 0
leonguyenz đã viết:
Bạn xem file đính kèm
Mã: 
Sub TongHop2()
Dim Data(), Arr(), i As Long, TenKh As String, j As Long, k As Long
Data = Sheet2.Range("A2:F15").Value
ReDim Arr(1 To UBound(Data, 1), 1 To 7)
    For i = 1 To UBound(Data)
        If Data(i, 1) = "Tên KH" Then TenKh = Data(i, 2)
        If IsDate(Data(i, 1)) Then
            k = k + 1
            Arr(k, 1) = TenKh
            For j = 1 To 6
                Arr(k, j + 1) = Data(i, j)
            Next j
        End If
    Next i
If k Then
    Sheet2.Range("H2").Resize(1000, 7).ClearContents
    Sheet2.Range("H2").Resize(k, 7).Value = Arr
End If
End Sub
Nhấp chuột vào đây để mở rộng...

Xin chào các bạn,
Với code trên của anh leonguyenz , Oanh Thơ đang thử loay hoay với cách sử dụng ReDim Preserve cho mảng Arr, sao cho chiều thứ nhất số phần thử trong mảng bằng k.
Nhưng chưa biết xử lý thế nào, code chạy toàn báo lỗi nhờ các bạn chỉ dẫn ạ :(
 
Upvote 0
Nguyễn Hoàng Oanh Thơ đã viết:
Xin chào các bạn,
Với code trên của anh leonguyenz , Oanh Thơ đang thử loay hoay với cách sử dụng ReDim Preserve cho mảng Arr, sao cho chiều thứ nhất số phần thử trong mảng bằng k.
Nhưng chưa biết xử lý thế nào, code chạy toàn báo lỗi nhờ các bạn chỉ dẫn ạ :(
Nhấp chuột vào đây để mở rộng...
Với VBA: Redim Preserve chỉ cho thay đổi chiều cuối của mảng, tức là mảng 2 chiều thì cho thay đổi theo chiều thứ 2 (cột) của mảng . Nên theo k là không thể
 
Upvote 0
Nguyễn Hoàng Oanh Thơ đã viết:
...cách sử dụng ReDim Preserve cho mảng Arr, sao cho chiều thứ nhất số phần thử trong mảng bằng k.
Nhưng chưa biết xử lý thế nào, code chạy toàn báo lỗi nhờ các bạn chỉ dẫn ạ :(
Nhấp chuột vào đây để mở rộng...
Lại "chạy toàn báo lỗi" !!! Lỗi gì? Ở dòng nào?

Mảng 2 chiều phải không? Chịu khó tìm, vấn đề này và các cách giải quyết đã từng được bàn qua rồi.
 
Upvote 0
Xin chào tam888, Bác VetMini,
Cảm ơn mọi người đã giúp đỡ Oanh Thơ ạ.

VetMini đã viết:
Lại "chạy toàn báo lỗi" !!! Lỗi gì? Ở dòng nào?
Mảng 2 chiều phải không? Chịu khó tìm, vấn đề này và các cách giải quyết đã từng được bàn qua rồi.
Nhấp chuột vào đây để mở rộng...

Híc, con xin lỗi Bác con quên mất ..
nó bị lỗi "Subscript out of range" tại dòng ReDim Preserve Arr(1 To k, 1 To 7)
Nhờ Bác chỉ dẫn thêm cho ạ.

Mã: 
Sub TongHop2()
    Dim Data(), Arr(), i As Long, TenKh As String, j As Long, k As Long
    Sheet2.Range("H2").Resize(1000, 7).ClearContents
    Data = Sheet2.Range("A2:F15").Value
    ReDim Arr(1 To UBound(Data, 1), 1 To 7)
        For i = 1 To UBound(Data)
            If Data(i, 1) = "Tên KH" Then TenKh = Data(i, 2)
            If IsDate(Data(i, 1)) Then
                k = k + 1
                ReDim Preserve Arr(1 To k, 1 To 7)
                Arr(k, 1) = TenKh
                For j = 1 To 6
                    Arr(k, j + 1) = Data(i, j)
                Next j
            End If
        Next i
    If k Then
        Sheet2.Range("H2").Resize(k, 7).Value = Arr
    End If
End Sub
 
Upvote 0
Nguyễn Hoàng Oanh Thơ đã viết:
Xin chào tam888, Bác VetMini,
Cảm ơn mọi người đã giúp đỡ Oanh Thơ ạ.



Híc, con xin lỗi Bác con quên mất ..
nó bị lỗi "Subscript out of range" tại dòng ReDim Preserve Arr(1 To k, 1 To 7)
Nhờ Bác chỉ dẫn thêm cho ạ.

Mã: 
Sub TongHop2()
    Dim Data(), Arr(), i As Long, TenKh As String, j As Long, k As Long
    Sheet2.Range("H2").Resize(1000, 7).ClearContents
    Data = Sheet2.Range("A2:F15").Value
    ReDim Arr(1 To UBound(Data, 1), 1 To 7)
        For i = 1 To UBound(Data)
            If Data(i, 1) = "Tên KH" Then TenKh = Data(i, 2)
            If IsDate(Data(i, 1)) Then
                k = k + 1
                ReDim Preserve Arr(1 To k, 1 To 7)
                Arr(k, 1) = TenKh
                For j = 1 To 6
                    Arr(k, j + 1) = Data(i, j)
                Next j
            End If
        Next i
    If k Then
        Sheet2.Range("H2").Resize(k, 7).Value = Arr
    End If
End Sub
Nhấp chuột vào đây để mở rộng...
Bỏ dòng đó đi là được.
 
Upvote 0
Bạn phải đăng nhập hoặc đăng ký để trả lời bài viết tại đây.

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

Nguyenkhang2404
Tính định mức sản phẩm (1 người xem)
    • Chấp nhận
Trả lời
9
Đọc
233
Nguyenkhang2404
Nguyenkhang2404
H
Lỗi khi sort data xin được hỗ trợ (1 người xem)
Trả lời
1
Đọc
34
Maithy46
Maithy46
ongke0711
  • Question Question
Tải hóa đơn điện tử (https://hoadondientu.gdt.gov.vn/) Excel Vba (1 người xem)
    • Thích
    • Yêu thích
    • Cảm ơn
2 3 4
Trả lời
389
Đọc
45K
THANHHANGPT
T
8
Theo dõi bán hàng
Trả lời
6
Đọc
119
Maithy46
Maithy46
T
Ngắt kết nối với tệp lệnh đính kèm
Trả lời
2
Đọc
79
TungXauGiai
T
ongke0711
  • Question Question
Trộn dữ liệu từ Excel sang Word mở rộng (phiên bản ongke0711)
    • Thích
    • Yêu thích
    • Cảm ơn
2 3
Trả lời
277
Đọc
35K
joker102
J
minhduc1o2
Hình ảnh bị lỗi #VALUE (1 người xem)
Trả lời
4
Đọc
74
minhduc1o2
minhduc1o2
S
tỷ lệ % không khớp khi cộng tổng
Trả lời
2
Đọc
54
snoobcool
S
D
Tên sheet bị che khuất khi thực hiện sửa tên sheet
Trả lời
1
Đọc
235
PhamMaiTB
P
thanhcongdnk
nhờ các cao nhân giúp dùm, xin đa tạ nhiều
    • Buồn
    • Phẫn nộ
Trả lời
2
Đọc
406
misibi
M
N
  • Question Question
Chia sẻ COM DLL giúp tra cứu mã số thuế từ trang web masothue.com (1 người xem)
    • Thích
Trả lời
1
Đọc
404
nguyendang95
N
hoidebiet1710
Doanh thu cho nhiều nhân viên bán hàng
Trả lời
1
Đọc
94
BuiQuangThuan
B
ongke0711
  • Question Question
Tra cứu thông tin mã số thuế (cập nhật lại code cũ) (1 người xem)
    • Thích
    • Cảm ơn
    • Yêu thích
Trả lời
1
Đọc
121
hoidebiet1710
hoidebiet1710
V
  • Question Question
Nhờ mọi người giúp cách xóa các mục đã chọn trong Droplist của một nhóm các ô cùng dạy một môn học.
Trả lời
3
Đọc
198
HUONGHCKT
H
L
Trừ lùi nguyên vật liệu nhập - xuất - tồn theo nhiều điều kiện (1 người xem)
Trả lời
7
Đọc
757
oanhleqt
O
D
Lọc cột chứa nhiều nhóm từ trong Excel. Mong các bạn giải đáp giúp
Trả lời
8
Đọc
183
Thai Huyen
Thai Huyen
T
file excel bị lỗi
Trả lời
1
Đọc
50
BuiQuangThuan
B
dungluyen2119
  • Question Question
Code VBA để tính tổng theo chiều ngang mà số cột không cố định
Trả lời
4
Đọc
150
HUONGHCKT
H
H
Câu lệnh mở file Excel trong Macbook Pro 1
Trả lời
0
Đọc
53
huafu_Jackl
H
N
Tạo COM Add-In bằng Visual C++
    • Thích
Trả lời
8
Đọc
806
nguyendang95
N
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

Thời gian đếm ngược.

000
Ngày
00
Giờ
00
phút
00
giây
Thân mời tham dự sự kiện sinh nhật GPE 2025
Back
Top Bottom