Chuyển từ mảng 2 chiều qua mảng 1 chiều (1 người xem)

thunoka · 20/10/08

Chào các bạn,

Mình mới làm wen với VBA nên không biết làm sao để chuyển từ mảng 2 chiều sang mảng 1 chiều. Các bạn có thể coi hình này:

Cho mình hỏi là phải code như thế nào để có mảng như trên?

Mong các bạn giúp mình với! Cảm ơn các bạn nhiều lắm!

ndu96081631 · 21/10/08

voda đã viết:
ndu đọc bài #9 sẽ thấy yêu cầu của bạn thunoka : muốn chuyển nhiều mãng 2 chiều thành mãng 1 chiều. (Tuy nhiên hình mình họa chưa chuẩn lắm ). Ý của mình đúng như bạn nói.

Nếu vậy thì vẩn như em nói ở trên, em thêm vòng lập duyệt qua các Areas như sau:

PHP:

Option Explicit
Sub Test()
  Dim Rng As Range, TempRng As Range, Des As Range, StDes
  Dim i As Long, j As Long, k As Long
  On Error GoTo Thoat
  Set Rng = Application.InputBox("Chon vung du lieu nguon", Type:=8)
  Set StDes = Application.InputBox("Chon vung dat ket qua", Type:=8)
  For i = 1 To Rng.Areas.Count
    k = 0
    With Rng.Areas(i)
      For j = 1 To .Columns.Count
       Set TempRng = .Offset(, j - 1).Resize(, 1)
       Set Des = StDes.Offset((i - 1), k * TempRng.Count).Resize(, TempRng.Count)
       Des.Value = WorksheetFunction.Transpose(TempRng)
       k = k + 1
      Next j
    End With
  Next i
Thoat:   Exit Sub
End Sub

Có thể chuyển thoải mái nhiều mãng 2 chiều thành 1 chiều và đặt vùng kết quả sang bất cứ sheet nào

ptm0412 · 21/10/08

Yêu cầu của tác giả là:

nếu có nhiều mảng 2 chiều, muốn chuyển thành nhiều mảng 1 chiều như hình dưới thì làm thế nào?

Nếu dùng code của ndu bài trên, có thể làm được nếu thêm 1 msgbox hỏi "tiếp không?" để lần lượt làm từng mảng.

PHP:

Sub Test()
Dim Rng As Range, TempRng As Range, Des As Range, StDes
  Dim i As Long, j As Long, k As Long
  On Error GoTo Thoat
  Set Rng = Application.InputBox("Chon vung du lieu nguon", Type:=8)
  Set StDes = Application.InputBox("Chon vung dat ket qua", Type:=8)
  For i = 1 To Rng.Areas.Count
    k = 0
    With Rng.Areas(i)
      For j = 1 To .Columns.Count
       Set TempRng = .Offset(, j - 1).Resize(, 1)
       Set Des = StDes.Offset((i - 1), k * TempRng.Count).Resize(, TempRng.Count)
       Des.Value = WorksheetFunction.Transpose(TempRng)
       k = k + 1
      Next j
    End With
  Next i
Tiep = MsgBox("Tiep?", vbYesNo)
    If Tiep = vbYes Then
    Test
    Else
    Exit Sub
End If
Thoat:   Exit Sub
End Sub

Đang định nói về chuỵên lỡ người dùng nhấn cancel thì... ndu đã thêm GoTo Thoat rồi.

rollover79 · 21/10/08

ptm0412 đã viết:
PHP:

Tiep = MsgBox("Tiep?", vbYesNo) If Tiep = vbYes Then Test Else Exit Sub End If Thoat: Exit Sub

Chỗ này mà bác viết nhiều dòng code quá, có thể gọn lại như sau

Mã:

IF MsgBox("Tiep tuc nua chu?", vbYesNo) = vbYes then Test

ThuNghi · 21/10/08

Tham gia thêm 1 cách dùng Find Method. Có dùng bài của RollOver79

PHP:

Sub ChangeRng()
Dim MyRng As Range, iL As Long, lCount As Long, RngFound As Range
[A1].Select
Set MyRng = Application.InputBox("Chon vung du lieu nguon", Type:=8)
Set STDes = Application.InputBox("Chon vung dat ket qua", Type:=8)
lCount = MyRng.Count
With MyRng
    Set RngFound = MyRng(1)
    STDes.Value = RngFound
    For iL = 1 To lCount - 1
    Set RngFound = .Find(What:="*", after:=RngFound, LookIn:=xlFormulas, LookAt _
        :=xlPart, SearchOrder:=xlByColumns)
        STDes.Offset(, iL) = RngFound
    Next
End With
If MsgBox("Tiep tuc nua chu?", vbYesNo) = vbYes Then ChangeRng
End Sub

Có 1 cái chưa biết là nếu rỗng thì nó bỏ qua.
Xin chỉ giáo.

ndu96081631 · 21/10/08

ThuNghi đã viết:

Tham gia thêm 1 cách dùng Find Method. Có dùng bài của RollOver79

PHP:

Sub ChangeRng()
Dim MyRng As Range, iL As Long, lCount As Long, RngFound As Range
[A1].Select
Set MyRng = Application.InputBox("Chon vung du lieu nguon", Type:=8)
Set STDes = Application.InputBox("Chon vung dat ket qua", Type:=8)
lCount = MyRng.Count
With MyRng
    Set RngFound = MyRng(1)
    STDes.Value = RngFound
    For iL = 1 To lCount - 1
    Set RngFound = .Find(What:="*", after:=RngFound, LookIn:=xlFormulas, LookAt _
        :=xlPart, SearchOrder:=xlByColumns)
        STDes.Offset(, iL) = RngFound
    Next
End With
If MsgBox("Tiep tuc nua chu?", vbYesNo) = vbYes Then ChangeRng
End Sub

Có 1 cái chưa biết là nếu rỗng thì nó bỏ qua.
Xin chỉ giáo.

Dử liệu loại khác và yêu cầu khác thì tôi không dám nói, nhưng ở trường hợp này e rằng FIND không thể nhanh hơn TRANSPOSE rồi

Dauthivan · 10/3/12

Cho em được hỏi dùng Code gì để kiểm tra mảng một mảng bất kỳ để biết nó là mảng ngang hay mảng dọc, mảng 1 chiều hay là 2 chiều?

Xin cho em một ví dụ ah, em xin cảm ơn

ndu96081631 · 10/3/12

Dauthivan đã viết:
Cho em được hỏi dùng Code gì để kiểm tra mảng một mảng bất kỳ để biết nó là mảng ngang hay mảng dọc, mảng 1 chiều hay là 2 chiều?

Xin cho em một ví dụ ah, em xin cảm ơn

Đã là mảng thì không có vụ DỌC NGANG gì cả mà chỉ tính nó mấy chiều thôi (1 chiều, 2 chiều, 3 chiều,... vân vân...)
Để tính số chiều của 1 Array, có thể dùng UDF này:

PHP:

Function Dimensions(ByVal sArray) As Long
  Dim chkDim As Long, lCount As Long, tmpArr
  On Error Resume Next
  tmpArr = sArray
  If IsArray(tmpArr) Then
    Do While Err.Number = 0
      lCount = lCount + 1
      chkDim = LBound(tmpArr, lCount)
    Loop
   Dimensions = lCount - 1
  End If
End Function

Thí nghiệm hàm trên xem sao:

PHP:

Sub Test()
  Dim sArray
  sArray = Range("A1:C10")
  MsgBox Dimensions(sArray)
  sArray = Array(1, 2, 3)
  MsgBox Dimensions(sArray)
  sArray = Range("N1")
  MsgBox Dimensions(sArray)
End Sub

theman · 16/2/15

ndu96081631 đã viết:
Nếu vậy thì vẩn như em nói ở trên, em thêm vòng lập duyệt qua các Areas như sau:

PHP:

Option Explicit Sub Test() Dim Rng As Range, TempRng As Range, Des As Range, StDes Dim i As Long, j As Long, k As Long On Error GoTo Thoat Set Rng = Application.InputBox("Chon vung du lieu nguon", Type:=8) Set StDes = Application.InputBox("Chon vung dat ket qua", Type:=8) For i = 1 To Rng.Areas.Count k = 0 With Rng.Areas(i) For j = 1 To .Columns.Count Set TempRng = .Offset(, j - 1).Resize(, 1) Set Des = StDes.Offset((i - 1), k * TempRng.Count).Resize(, TempRng.Count) Des.Value = WorksheetFunction.Transpose(TempRng) k = k + 1 Next j End With Next i Thoat: Exit Sub End Sub

Có thể chuyển thoải mái nhiều mãng 2 chiều thành 1 chiều và đặt vùng kết quả sang bất cứ sheet nào

Các anh chị cho e hỏi là e muốn chuyển mảng 2 chiều thành mảng 1 chiều dưới dạng cột dọc và bỏ qua những giá trị trống ở mảng hai chiều thì phải sửa code ở trên như thế nào ạ?

sakutara1505 · 3/2/17

Mọi người cho em hỏi là em muốn chuyển mảng:
1 2 3 4
5 6 7 8
9 10 11 12
thành dạng một chiều như thế này:
1 5 9 10 6 2 3 7 11 12 8 4
thì phải làm như thế nào ạ?
Mong được các anh chị chỉ giáo

befaint · 3/2/17

sakutara1505 đã viết:
Mọi người cho em hỏi là em muốn chuyển mảng:
1 2 3 4
5 6 7 8
9 10 11 12
thành dạng một chiều như thế này:
1 5 9 10 6 2 3 7 11 12 8 4
thì phải làm như thế nào ạ?
Mong được các anh chị chỉ giáo

Mã:

Dim arr, KQ(), i as long, j as long, k as long, z as long, n as long
'arr=mảng ban đầu
n=ubound(arr,1):z=ubound(arr,2)
redim KQ(1 to n*z)
For k=1 to z
   For j=1 to n
      i=i+1: KQ(i)=arr(j,k)
next j
next k
'Kết thúc

sakutara1505 · 3/2/17

befaint đã viết:

Mã:

Dim arr, KQ(), i as long, j as long, k as long, z as long, n as long
'arr=mảng ban đầu
n=ubound(arr,1):z=ubound(arr,2)
redim KQ(1 to n*z)
For k=1 to z
   For j=1 to n
      i=i+1: KQ(i)=arr(j,k)
next j
next k
'Kết thúc

Pro có thể viết code đầy đủ được ko? Mình gà mờ lắm :d

Chuyển từ mảng 2 chiều qua mảng 1 chiều (1 người xem)

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

thunoka

Guest

ndu96081631

Huyền thoại GPE

File đính kèm

ptm0412

Bad Excel Member

rollover79

Thành viên tiêu biểu

ThuNghi

Hãy cho rồi sẽ nhận!

ndu96081631

Huyền thoại GPE

Dauthivan

Thành viên tiêu biểu

ndu96081631

Huyền thoại GPE

theman

Thành viên mới

sakutara1505

Thành viên mới

befaint

|||||||||||||

sakutara1505

Thành viên mới

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

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