Bất lực Nhờ các cao nhân giúp đỡ - Chuyển tất cả giá trị trong bảng tính vào 1 dòng

Liên hệ QC
Status
Không mở trả lời sau này.
manhtoank50

manhtoank50

Thành viên mới
Tham gia
13/1/11
Bài viết
8
Được thích
2
Nghề nghiệp
Project management
Chào cả nhà,

Mình đang gặp 1 trường hợp đã nghĩ 2 ngày nay chưa ra giải pháp. Mong mọi người giúp đỡ:

Cần làm:
Lấy tất cả các giá trị trong bảng và sắp xếp lại theo chiều dọc của 1 cột. Các giá trị xếp theo chiều dọc không cần theo thứ tự.
Do file gốc của mình lên đến 7500 dòng, 3000 cột nên với cách làm copy paste thủ công là bất khả thi, hoặc sử dụng theo mấy công thức thì khi kéo Excel đơ luôn.
Mình gửi file demo, nhờ mọi người giúp đỡ
 

File đính kèm

  • Xin giup do.xlsx
    9.1 KB · Đọc: 15
Lần chỉnh sửa cuối:
Nguyễn Hoàng Oanh Thơ đã viết:
Bạn kiểm tra thử nhé.
Nhấp chuột vào đây để mở rộng...
PHP: 
    Const sRws As Long = 7500 'so cot
    Const sCol As Long = 3000 'so dong
    '// sRws*sCol = 7500*3000 = 22,500,000 >>> 1,048,576 rows of worksheet
nên chỗ này cần đánh giá số lượng kết quả trả về trước khi khai báo lại kích thước cho RsArr.
Mã: 
MyArr = .Range("D6").Resize(sRws, sCol).Value2
ReDim RsArr(1 To UBound(MyArr) * UBound(MyArr, 2), 1 To 1)
 
befaint đã viết:
PHP: 
    Const sRws As Long = 7500 'so cot
    Const sCol As Long = 3000 'so dong
    '// sRws*sCol = 7500*3000 = 22,500,000 >>> 1,048,576 rows of worksheet
nên chỗ này cần đánh giá số lượng kết quả trả về trước khi khai báo lại kích thước cho RsArr.
Mã: 
MyArr = .Range("D6").Resize(sRws, sCol).Value2
ReDim RsArr(1 To UBound(MyArr) * UBound(MyArr, 2), 1 To 1)
Nhấp chuột vào đây để mở rộng...

Mình mù tịt VBA luôn. Mình gửi file gốc bạn xem giúp mình nhé. Cột và dòng nhiều, nhưng dữ liệu không phải ô nào cũng có nên khi ghép lại chỉ rơi vào 200,000 dòng thôi.
 

File đính kèm

  • TEST18.xlsx
    201.4 KB · Đọc: 7
befaint đã viết:
PHP: 
    Const sRws As Long = 7500 'so cot
    Const sCol As Long = 3000 'so dong
    '// sRws*sCol = 7500*3000 = 22,500,000 >>> 1,048,576 rows of worksheet
nên chỗ này cần đánh giá số lượng kết quả trả về trước khi khai báo lại kích thước cho RsArr.
Mã: 
MyArr = .Range("D6").Resize(sRws, sCol).Value2
ReDim RsArr(1 To UBound(MyArr) * UBound(MyArr, 2), 1 To 1)
Nhấp chuột vào đây để mở rộng...

Xin chào @befaint,
Cảm ơn bạn đã chỉ dẫn , Oanh Thơ (OT) cũng không nghĩ dữ liệu thực lại có thể nhiều đến mức đó,hic tập tin Excel >300MB mà mở lên được cũng thật khó tin.
OT cũng thấy mình có chút may mắn cũng từng được một người bạn giúp cho đoạn code,và xin phép được chia sẻ ở đây.
Hi vọng sẽ giúp được vấn đề của @manhtoank50 và sẽ giúp cho những bạn đang tiếp cận với lập trình trong Execel như OT :
Mã: 
Option Explicit

Sub Gopx()
    '// Const thi de len tren cung cua Sub/ Function
    Const sRws As Long = 7500 'so cot
    Const sCol As Long = 3000 'so dong
    '// sRws*sCol = 7500*3000 = 22,500,000 >>> 1,048,576 rows of worksheet
    '// gia su co nhieu ket qua nen can tach thanh nhieu cot, môi côt có maxR dòng
    Const maxR As Long = 1048500 'so dong ket qua
    Const M As Long = 16384 '
    Dim arr(), Res(), i As Long, j As Long, k As Long, N As Long
    Dim Rng As Range, maxC As Long, sText As String, ik As Long
    With Sheet1
        Set Rng = .Range("D6").Resize(sRws, sCol)
        arr = Rng.Value2
    End With
    N = Application.WorksheetFunction.CountA(Rng)
    If N = 0 Then MsgBox "khong co du lieu": Exit Sub
    '// tinh sô côt kêt qua:
    maxC = Fix(N / maxR) + 1
    '// xem xet kiem tra maxC voi sô côt tôi da cua bang tinh 16,384 côt,
    '// neu maxC > 16,384 thi chia ket qua sang 1 hay nhiêu bang tinh
    '// tam thoi chi lay cho môt bang tinh
    ReDim Res(1 To maxR, 1 To maxC)
    ik = 1
    For i = 1 To sRws
        For k = 1 To sCol
            sText = arr(i, k)
            If Len(sText) > 0 Then  '// nêu có gia tri moi lây
                j = j + 1
                If j > maxR Then    '// nêu so dong ket qua > maxR thi chuyên sang côt moi
                    j = 1           '// dong dau tien cua cot moi
                    ik = ik + 1     '// sang cot moi
                End If
                If ik > M Then      '// neu so luong cot ket qua > M=16384
                    ik = ik - 1
                    MsgBox "Nhiêu kêt qua!!! Chi lây " & ik & "côt kêt qua."
                    GoTo nextCode
                End If
                Res(j, ik) = sText
            End If
        Next k
    Next i
nextCode:
    '// gan ket qua sang sheet moi
    Sheet2.UsedRange.ClearContents
    Sheet2.Range("A2").Resize(maxR, ik).Value = Res
End Sub

Code thấy quen quen quá ahuhu, cảm ơn bạn nhiều lắm...
 
Nguyễn Hoàng Oanh Thơ đã viết:
Xin chào @befaint,
Cảm ơn bạn đã chỉ dẫn , Oanh Thơ (OT) cũng không nghĩ dữ liệu thực lại có thể nhiều đến mức đó,hic tập tin Excel >300MB mà mở lên được cũng thật khó tin.
OT cũng thấy mình có chút may mắn cũng từng được một người bạn giúp cho đoạn code,và xin phép được chia sẻ ở đây.
Hi vọng sẽ giúp được vấn đề của @manhtoank50 và sẽ giúp cho những bạn đang tiếp cận với lập trình trong Execel như OT :
Mã: 
Option Explicit

Sub Gopx()
    '// Const thi de len tren cung cua Sub/ Function
    Const sRws As Long = 7500 'so cot
    Const sCol As Long = 3000 'so dong
    '// sRws*sCol = 7500*3000 = 22,500,000 >>> 1,048,576 rows of worksheet
    '// gia su co nhieu ket qua nen can tach thanh nhieu cot, môi côt có maxR dòng
    Const maxR As Long = 1048500 'so dong ket qua
    Const M As Long = 16384 '
    Dim arr(), Res(), i As Long, j As Long, k As Long, N As Long
    Dim Rng As Range, maxC As Long, sText As String, ik As Long
    With Sheet1
        Set Rng = .Range("D6").Resize(sRws, sCol)
        arr = Rng.Value2
    End With
    N = Application.WorksheetFunction.CountA(Rng)
    If N = 0 Then MsgBox "khong co du lieu": Exit Sub
    '// tinh sô côt kêt qua:
    maxC = Fix(N / maxR) + 1
    '// xem xet kiem tra maxC voi sô côt tôi da cua bang tinh 16,384 côt,
    '// neu maxC > 16,384 thi chia ket qua sang 1 hay nhiêu bang tinh
    '// tam thoi chi lay cho môt bang tinh
    ReDim Res(1 To maxR, 1 To maxC)
    ik = 1
    For i = 1 To sRws
        For k = 1 To sCol
            sText = arr(i, k)
            If Len(sText) > 0 Then  '// nêu có gia tri moi lây
                j = j + 1
                If j > maxR Then    '// nêu so dong ket qua > maxR thi chuyên sang côt moi
                    j = 1           '// dong dau tien cua cot moi
                    ik = ik + 1     '// sang cot moi
                End If
                If ik > M Then      '// neu so luong cot ket qua > M=16384
                    ik = ik - 1
                    MsgBox "Nhiêu kêt qua!!! Chi lây " & ik & "côt kêt qua."
                    GoTo nextCode
                End If
                Res(j, ik) = sText
            End If
        Next k
    Next i
nextCode:
    '// gan ket qua sang sheet moi
    Sheet2.UsedRange.ClearContents
    Sheet2.Range("A2").Resize(maxR, ik).Value = Res
End Sub

Code thấy quen quen quá ahuhu, cảm ơn bạn nhiều lắm...
Nhấp chuột vào đây để mở rộng...
code này giống như của Anh LA thì phải???
 
Mình thử với Function của tác giả
ndu96081631
bạn có thể thử ?
Mã: 
Option Explicit
Sub GopThanh1Cot()
 Dim ArrKetQua, ArrDulieu As Range, soCot As Long
  For soCot = 1 To 2901
    Set ArrDulieu = Sheet1.Range("A1:A5000").Offset(, (soCot - 1) * 1)
    If Not IsArray(ArrKetQua) Then
      ArrKetQua = Join2DArray(ArrDulieu)
    Else
      ArrKetQua = Join2DArray(ArrKetQua, ArrDulieu)
    End If
  Next
  Sheet2.Range("A2").Resize(UBound(ArrKetQua, 1), 1).Value = ArrKetQua
  MsgBox "Done!"
End Sub
'Tac Gia ndu
Function Join2DArray(ParamArray arrays())
  Dim arr(), aSub, tmp
  Dim lRs As Long, lCs As Long, lR As Long, lC As Long
  Dim n As Long, m As Long, i As Long, bChk As Boolean
  On Error Resume Next

  For i = 0 To UBound(arrays)
    aSub = arrays(i)
    n = UBound(aSub, 1) - LBound(aSub, 1) + 1
    lRs = lRs + n
    m = UBound(aSub, 2) - LBound(aSub, 2) + 1
    If lCs < m Then lCs = m
  Next
 
  ReDim arr(1 To lCs, 1 To lRs)
  n = 0: m = 0
  For i = 0 To UBound(arrays)
    aSub = arrays(i)
    For lR = LBound(aSub, 1) To UBound(aSub, 1)
      bChk = False
      n = n + 1
      For lC = LBound(aSub, 2) To UBound(aSub, 2)
        tmp = aSub(lR, lC)
        Select Case VarType(tmp)
          Case 0 To 1: arr(lC, n) = vbNullString
          Case 2 To 7: arr(lC, n) = tmp
          Case 8
            If IsNumeric(tmp) Then
              arr(lC, n) = "'" & tmp
            Else
              arr(lC, n) = tmp
            End If
        End Select
        If Len(CStr(tmp)) Then bChk = True
      Next
      If bChk = False Then n = n - 1
    Next
  Next
  If n Then
    ReDim Preserve arr(1 To lCs, 1 To n)
    Join2DArray = Transpose2DArray(arr)
  End If
End Function
Function Transpose2DArray(ByVal arr2D)
  Dim arr(), aTemp
  Dim lR As Long, lC As Long
  On Error Resume Next
  aTemp = arr2D
  ReDim arr(LBound(aTemp, 2) To UBound(aTemp, 2), LBound(aTemp, 1) To UBound(aTemp, 1))
  For lR = LBound(aTemp, 1) To UBound(aTemp, 1)
    For lC = LBound(aTemp, 2) To UBound(aTemp, 2)
      arr(lC, lR) = aTemp(lR, lC)
    Next
  Next
  Transpose2DArray = arr
End Function
 
manhtoank50 đã viết:
Chào cả nhà,

Mình đang gặp 1 trường hợp đã nghĩ 2 ngày nay chưa ra giải pháp. Mong mọi người giúp đỡ:

Cần làm:
Lấy tất cả các giá trị trong bảng và sắp xếp lại theo chiều dọc của 1 cột. Các giá trị xếp theo chiều dọc không cần theo thứ tự.
Do file gốc của mình lên đến 7500 dòng, 3000 cột nên với cách làm copy paste thủ công là bất khả thi, hoặc sử dụng theo mấy công thức thì khi kéo Excel đơ luôn.
Mình gửi file demo, nhờ mọi người giúp đỡ
Nhấp chuột vào đây để mở rộng...
Sử dụng Code còn muốn đơ nói chi là sử dụng hàm.
Tôi chưa bao giờ sử dụng đến 100 cột chứ nói chi là đến 3000 cột.
Tôi khuyên nên đưa File thực tế lên để các thành viên thiết kế lại để nhập liệu theo chiều dọc sẽ gọn hơn.
 
Status
Không mở trả lời sau này.
Web KT

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

H
Kết nối vba với Database host (hiện tại đang làm host web)
Trả lời
5
Đọc
180
Haidang7979
H
A
  • Question
cách dùng lockxls bảo vệ file
Trả lời
15
Đọc
3K
YêuCN
Y
S
Slicer không chuyển qua trạng thái mờ.
Trả lời
4
Đọc
80
SteveNguyen1991
S
S
  • Question
Không lấy đủ dữ liệu bằng kết nối ADO
2
Trả lời
29
Đọc
460
shnhatha221108
S
LuuAnh980
  • Question
Code lấy dữ liệu từ 3 file con.
2 3
Trả lời
54
Đọc
736
ptm0412
ptm0412
Xem thêm…

Facebook

Giaiphapexcel.com

Group

DIỄN ĐÀN GIẢI PHÁP EXCEL Group 1
DIỄN ĐÀN GIẢI PHÁP EXCEL Group 2

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

  • Không tìm thấy.
Back
Top Bottom