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 (3 người xem)

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)
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

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

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

G
Xin Code xóa Module.
Trả lời
4
Đọc
92
PhanTuHuong
PhanTuHuong
D
  • Question Question
Quản lý email outlook qua VBA cần giúp đỡ (3 người xem)
Trả lời
12
Đọc
220
nguyendang95
N
PhanTuHuong
Sách Lập trình VBA trong AutoCAD đã có mặt
    • Thích
    • Yêu thích
2
Trả lời
21
Đọc
1K
PhanTuHuong
PhanTuHuong
L
Lỗi font khi convert từ pdf
Trả lời
3
Đọc
117
lamvu0677
L
N
Khắc phục lỗi "The picture is too large and will be truncated"
Trả lời
9
Đọc
5K
SonBDND
S
GPE-Trợ Lý
[GPE] TALKSHOW: PHÂN TÍCH BÁO CÁO ĐỘ NHẠY SỬ DỤNG EXCEL SOLVER (1 người xem)
    • Thích
Trả lời
0
Đọc
164
GPE-Trợ Lý
GPE-Trợ Lý
K
  • Question Question
nhờ ace giúp đỡ tự động filter và In hàng loạt từng mục trong piviot table
Trả lời
1
Đọc
88
khkkh
K
K
Xin dax tính tỷ trọng doanh thu
Trả lời
18
Đọc
762
SteveNguyen1991
S
F
  • Question Question
Tự động Merge Mail bằng VBA
Trả lời
6
Đọc
191
Hoàng Tuấn 868
H
N
Một ví dụ về XLL add-in: Tương tác với Google Gemini dưới dạng công thức bảng tính
    • Thích
Trả lời
0
Đọc
96
nguyendang95
N
H
Nhờ anh/chị giúp đỡ em viết công thức trừ dữ liệu theo FiFo
Trả lời
1
Đọc
101
HieuCD
H
BNTT
LockXLS - Chương trình bảo vệ an toàn cho các file bảng tính Excel
    • Thích
4 5 6
Trả lời
118
Đọc
73K
YêuCN
Y
vsitcnh
Hỗ trợ công thức tính điểm dựa theo điều kiện.
Trả lời
14
Đọc
197
thuytrangbp28
T
micam111
  • Question Question
Cách chạy nhiều đồng hồ đếm giờ trong VBA
Trả lời
4
Đọc
693
thuytrangbp28
T
B
Xin giải pháp chống sửa, xóa dữ liệu đã nhập vào từ ngày hôm trước.
    • Thích
2
Trả lời
26
Đọc
7K
Tuấn Bụng Bự
Tuấn Bụng Bự
Emyeuexcel
  • Question Question
In tất cả các file trong cùng 1 thư mục
Trả lời
3
Đọc
208
Hoàng Tuấn 868
H
1
Hỏi về đánh dấu hàng ngang hàng dọc bằng màu khi kích chuột vào 1 ô
Trả lời
7
Đọc
202
Gà Công Nghệ
Gà Công Nghệ
P
Excell code vba : Tìm Cell để sửa dữ liệu (1 người xem)
    • Buồn
2
Trả lời
26
Đọc
579
Phạm Trường 80
P
D
Nhờ anh em giúp đỡ.
    • Buồn
Trả lời
2
Đọc
93
SA_DQ
SA_DQ
00029591
Cần hỗ trợ công thức tổng hợp dữ liệu không cần cột phụ Vlookup
Trả lời
2
Đọc
102
DeTong
D
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

Đếm ngược thời gian

000
Ngày
00
Giờ
00
phút
00
giây
TALK SHOW: CÙNG NHẢY LAM BA ĐA VỚI HÀM LAMBDA (λ) EXCEL 365
Back
Top Bottom