Tạo giúp em Code copy cột dọc thành hàng ngang! (1 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)
D

diepminhhong

Thành viên mới
Tham gia
4/8/09
Bài viết
46
Được thích
8
Anh chị có thể giúp mình viết code copy chuyển cột dọc thành hàng ngang như trong file giúp em với được k ạ? E cảm ơn mọi người.
 

File đính kèm

Bạn thử đoạn sau:
PHP: 
Sub Doc2Ngang()
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Dim lr As Long, rw As Long, i As Long, m As Long, rc As Long, CV As Long, ii As Long, j As Long
Dim arr, drr(), tmp, cel1 As Range, cel2 As Range
Set cel1 = Sheet1.Range("A1")
Set cel2 = Sheet1.Range("AA9") 'Sua lai thành = Sheet1.Range("AA1")
lr = cel1.End(xlDown).Row
arr = UniqueArray(Sheet1.Range("A2:A" & lr))
For i = 1 To UBound(arr)
    If arr(i, 1) <> "" Then
        rw = rw + 1
        cel2.Offset(1, 0).Offset(rw - 1).Value = arr(i, 1)
    End If
Next i
ReDim drr(1 To rw)
For i = 1 To rw
    drr(i) = WorksheetFunction.CountIf(Sheet1.Range("A2:A" & lr), arr(i, 1))
Next i
m = WorksheetFunction.Max(drr)
cel2.Value = cel1.Value
For i = 1 To 5
    For j = 1 To m
        rc = rc + 1
        If j = 1 Then cel2.Offset(0, rc) = cel1.Offset(0, i)
        If j > 1 Then cel2.Offset(0, rc) = cel1.Offset(0, i) & j - 1
    Next j
Next i
cel2.Offset(0, 5 * m + 1).Resize(1, 16).Value = _
cel1.Offset(0, 6).Resize(1, 16).Value
tmp = cel2.Offset(1).Resize(rw, 1).Value
For i = 1 To UBound(tmp)
    CV = WorksheetFunction.Match(tmp(i, 1), Sheets(1).Range("A1:A" & lr), 0)
    j = 1
    For ii = 1 To (5 * m) Step m
        cel2.Offset(i, ii).Resize(1, drr(i)).Value = _
        Application.Transpose(cel1.Offset(CV - 1, j).Resize(drr(i)))
        j = j + 1
    Next ii
    cel2.Offset(i, 5 * m + 1).Resize(1, 16).Value = _
    cel1.Offset(CV - 1, 6).Resize(1, 16).Value
Next i
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
Function UniqueArray:
PHP: 
Function UniqueArray(SrcRng As Range) 'ndu96081631 -GPE
  Dim Src, tmp As String, arr()
  Dim i As Long, j As Long, n As Long
  Src = SrcRng.Value
  ReDim arr(1 To UBound(Src, 1), 1 To UBound(Src, 2))
  With CreateObject("Scripting.Dictionary")
    For i = LBound(Src, 1) To UBound(Src, 1)
      tmp = ""
      For j = LBound(Src, 2) To UBound(Src, 2)
        tmp = tmp & Src(i, j)
      Next
      If tmp <> "" Then
        If Not .Exists(tmp) Then
          n = n + 1
          .Add tmp, ""
          For j = LBound(Src, 2) To UBound(Src, 2)
            arr(n, j) = Src(i, j)
          Next
        End If
      End If
    Next
  End With
  If j <> 0 Then
    UniqueArray = arr
  End If
End Function
 
Lần chỉnh sửa cuối:
diepminhhong đã viết:
Anh chị có thể giúp mình viết code copy chuyển cột dọc thành hàng ngang như trong file giúp em với được k ạ? E cảm ơn mọi người.
Nhấp chuột vào đây để mở rộng...
chạy thử code nầy
Mã: 
Sub CopyDoc_Ngang()
Dim Darr, arr(), i As Long, j As Integer, n As Integer, k As Integer
Darr = Range("a2:v" & Range("a2").End(xlDown).Row)
ReDim arr(1 To UBound(Darr), 1 To 97)
Application.ScreenUpdating = False
For i = 1 To UBound(Darr)
    k = k + 1
    arr(k, 1) = Darr(i, 1)
    For j = 82 To 97
        arr(k, j) = Darr(i, j - 75)
    Next j
    cot = 0
    For n = i To UBound(Darr)
        If Darr(n, 1) = Darr(i, 1) Then
            cot = cot + 1
            arr(k, cot + 1) = Darr(n, 2)
            arr(k, cot + 17) = Darr(n, 3)
            arr(k, cot + 33) = Darr(n, 4)
            arr(k, cot + 49) = Darr(n, 5)
            arr(k, cot + 65) = Darr(n, 6)
            If n = UBound(Darr) Then GoTo thoat
        Else
            i = n - 1
            GoTo tiep
        End If
    Next n
tiep:
Next i
thoat:
Range("aa2:ds" & Range("aa2").End(xlDown).Row).ClearContents
Range("aa2").Resize(k, 97) = arr
Application.ScreenUpdating = True
End Sub
 
Hai anh HieuCD và hpkhuong xem lại giúp em:
Số CV (chắc viết tắt của từ "công việc") ứng với mỗi "BBS" là tùy ý, dữ liệu trong file là em thí dụ thôi chứ còn nhiều "BBS" lắm.
Và khi đó, tiêu đề mục cũng thay đổi theo (không phải là tới CV15, ĐV15... mà là CV20, ĐV20 chẳng hạn).
 
Mã: 
Sub CopyDoc_Ngang1()
Dim Darr, arr(), i As Long, j As Integer, n As Integer, k As Integer, max As Integer
Darr = Range("a1:v" & Range("a2").End(xlDown).Row)
Application.ScreenUpdating = False
tmp = "": max = 0
For i = 2 To UBound(Darr)
    If Darr(i, 1) = tmp Then
        j = j + 1
    Else
        j = 1: tmp = Darr(i, 1)
    End If
    If j > max Then max = j
Next i
ReDim arr(1 To UBound(Darr), 1 To 17 + max * 5)
For j = 1 To 5 * max + 17
    Select Case j
        Case 1 To 2
            arr(1, j) = Darr(1, j)
        Case 3 To max + 1
            arr(1, j) = Darr(1, 2) & (j - 2)
        Case max + 2
            arr(1, j) = Darr(1, 3)
        Case max + 3 To 2 * max + 1
            arr(1, j) = Darr(1, 3) & (j - max - 2)
        Case 2 * max + 2
            arr(1, j) = Darr(1, 4)
        Case 2 * max + 3 To 3 * max + 1
            arr(1, j) = Darr(1, 4) & (j - 2 * max - 2)
        Case 3 * max + 2
            arr(1, j) = Darr(1, 5)
        Case 3 * max + 3 To 4 * max + 1
            arr(1, j) = Darr(1, 5) & (j - 3 * max - 2)
        Case 4 * max + 2
            arr(1, j) = Darr(1, 6)
        Case 4 * max + 3 To 5 * max + 1
            arr(1, j) = Darr(1, 6) & (j - 4 * max - 2)
        Case 5 * max + 2 To 5 * max + 17
            arr(1, j) = Darr(1, j - 5 * max + 5)
    End Select
Next j
k = 1
For i = 2 To UBound(Darr)
    k = k + 1
    arr(k, 1) = Darr(i, 1)
    For j = 5 * max + 2 To 5 * max + 17
        arr(k, j) = Darr(i, j - 5 * max + 5)
    Next j
    cot = 0
    For n = i To UBound(Darr)
        If Darr(n, 1) = Darr(i, 1) Then
            cot = cot + 1
            arr(k, cot + 1) = Darr(n, 2)
            arr(k, cot + 1 + max) = Darr(n, 3)
            arr(k, cot + 1 + 2 * max) = Darr(n, 4)
            arr(k, cot + 1 + 3 * max) = Darr(n, 5)
            arr(k, cot + 1 + 4 * max) = Darr(n, 6)
            If n = UBound(Darr) Then GoTo thoat
        Else
            i = n - 1
            GoTo tiep
        End If
    Next n
tiep:
Next i
thoat:
Range("aa1").CurrentRegion.ClearContents
Range("aa1").Resize(k, 5 * max + 17) = arr
Application.ScreenUpdating = True
End Sub
 
HieuCD đã viết:
Mã: 
Sub CopyDoc_Ngang1()
...
Range("aa1").CurrentRegion.ClearContents
Range("aa1").Resize(k, 5 * max + 17) = arr
Application.ScreenUpdating = True
End Sub
Nhấp chuột vào đây để mở rộng...
Ối anh ơi! Anh cứu em với. Em chạy code của anh xong mất hết dữ liệu ban đầu. Em nhờ các anh copy giúp em, chứ dữ liệu ban đầu thì giữ nguyên ạ.
 
befaint đã viết:
Ối anh ơi! Anh cứu em với. Em chạy code của anh xong mất hết dữ liệu ban đầu. Em nhờ các anh copy giúp em, chứ dữ liệu ban đầu thì giữ nguyên ạ.
Nhấp chuột vào đây để mở rộng...
mình chạy thử vẫn bình thường, chắc ăn bạn sửa chổ màu đỏ lại theo đoạn code dưới

Sub CopyDoc_Ngang1()
...
Range("aa1").CurrentRegion.ClearContents
Range("aa1").Resize(k, 5 * max + 17) = arr
Application.ScreenUpdating = True
End Sub
Mã: 
...
Next i
thoat:
[COLOR=#ff0000]Range("aa1:dsC" & Range("aa65000").End(xlUp).Row).ClearContents[/COLOR]
Range("aa1").Resize(k, 5 * max + 17) = arr
Application.ScreenUpdating = True
End Sub
 
Lần chỉnh sửa cuối:
HieuCD đã viết:
mình chạy thử vẫn bình thường, chắc ăn bạn sửa chổ màu đỏ lại theo đoạn code dưới

Sub CopyDoc_Ngang1()
...
Range("aa1").CurrentRegion.ClearContents
Range("aa1").Resize(k, 5 * max + 17) = arr
Application.ScreenUpdating = True
End Sub
Mã: 
...
Next i
thoat:
[COLOR=#ff0000]Range("aa1:dsC" & Range("aa65000").End(xlUp).Row).ClearContents[/COLOR]
Range("aa1").Resize(k, 5 * max + 17) = arr
Application.ScreenUpdating = True
End Sub
Nhấp chuột vào đây để mở rộng...

Code trên nếu bạn ở 1 sheet bất kì nào đó mà chạy thì mất hết dữ liệu là đúng rồi, nó tự hiểu range("aa1") nằm trong Active sheet.
 
Em cám ơn các anh đã giúp đỡ e code này. Phải nói là đúng như ý e mong muốn. Em chúc các anh sức khoẻ và công tác tốt.
 
Mã: 
...
ReDim arr(1 To UBound(Darr), 1 To 17 + max * 5)
For j = 1 To 5 * max + 17
    Select Case j
        Case 1 To 2
            arr(1, j) = Darr(1, j)
        Case 3 To max + 1
            arr(1, j) = Darr(1, 2) & (j - 2)
        Case max + 2
            arr(1, j) = Darr(1, 3)
        Case max + 3 To 2 * max + 1
            arr(1, j) = Darr(1, 3) & (j - max - 2)
        Case 2 * max + 2
            arr(1, j) = Darr(1, 4)
        Case 2 * max + 3 To 3 * max + 1
            arr(1, j) = Darr(1, 4) & (j - 2 * max - 2)
        Case 3 * max + 2
            arr(1, j) = Darr(1, 5)
        Case 3 * max + 3 To 4 * max + 1
            arr(1, j) = Darr(1, 5) & (j - 3 * max - 2)
        Case 4 * max + 2
            arr(1, j) = Darr(1, 6)
        Case 4 * max + 3 To 5 * max + 1
            arr(1, j) = Darr(1, 6) & (j - 4 * max - 2)
        Case 5 * max + 2 To 5 * max + 17
            arr(1, j) = Darr(1, j - 5 * max + 5)
    End Select
Next j
...
dùng code dưới thay thế đoạn code trên cho gọn hơn
Mã: 
ReDim arr(1 To UBound(Darr), 1 To 17 + max * 5)
For j = 1 To 5 * max + 17
    If j = 1 Then
        arr(1, j) = Darr(1, j)
    ElseIf j >= 5 * max + 2 Then
        arr(1, j) = Darr(1, j - 5 * max + 5)
    ElseIf j Mod max = 2 Then
        arr(1, j) = Darr(1, Int(j / max) + 2)
    Else
        arr(1, j) = Darr(1, Int((j - 2) / max) + 2) & ((j - 2) Mod max)
    End If
Next j
 
HieuCD đã viết:
Mã: 
...
ReDim arr(1 To UBound(Darr), 1 To 17 + max * 5)
For j = 1 To 5 * max + 17
    Select Case j
        Case 1 To 2
            arr(1, j) = Darr(1, j)
        Case 3 To max + 1
            arr(1, j) = Darr(1, 2) & (j - 2)
        Case max + 2
            arr(1, j) = Darr(1, 3)
        Case max + 3 To 2 * max + 1
            arr(1, j) = Darr(1, 3) & (j - max - 2)
        Case 2 * max + 2
            arr(1, j) = Darr(1, 4)
        Case 2 * max + 3 To 3 * max + 1
            arr(1, j) = Darr(1, 4) & (j - 2 * max - 2)
        Case 3 * max + 2
            arr(1, j) = Darr(1, 5)
        Case 3 * max + 3 To 4 * max + 1
            arr(1, j) = Darr(1, 5) & (j - 3 * max - 2)
        Case 4 * max + 2
            arr(1, j) = Darr(1, 6)
        Case 4 * max + 3 To 5 * max + 1
            arr(1, j) = Darr(1, 6) & (j - 4 * max - 2)
        Case 5 * max + 2 To 5 * max + 17
            arr(1, j) = Darr(1, j - 5 * max + 5)
    End Select
Next j
...
dùng code dưới thay thế đoạn code trên cho gọn hơn
Mã: 
ReDim arr(1 To UBound(Darr), 1 To 17 + max * 5)
For j = 1 To 5 * max + 17
    If j = 1 Then
        arr(1, j) = Darr(1, j)
    ElseIf j >= 5 * max + 2 Then
        arr(1, j) = Darr(1, j - 5 * max + 5)
    ElseIf j Mod max = 2 Then
        arr(1, j) = Darr(1, Int(j / max) + 2)
    Else
        arr(1, j) = Darr(1, Int((j - 2) / max) + 2) & ((j - 2) Mod max)
    End If
Next j
Nhấp chuột vào đây để mở rộng...

Anh HieuCD ơi, Anh có thể giúp e xử lý file này (file đính kèm) với được không ạ? Vẫn là file hôm trước anh làm giúp e nhưng e có thay đổi 1 chút đi. E cảm ơn anh nhiều, Chúc anh sức khỏe và thành công.
 

File đính kèm

diepminhhong đã viết:
Anh HieuCD ơi, Anh có thể giúp e xử lý file này (file đính kèm) với được không ạ? Vẫn là file hôm trước anh làm giúp e nhưng e có thay đổi 1 chút đi. E cảm ơn anh nhiều, Chúc anh sức khỏe và thành công.
Nhấp chuột vào đây để mở rộng...
nhìn file của bạn, mình hơi hoảng, từ từ mình nghiên cứu và gởi code sau
 
bạn kiể tra lại code
Mã: 
Sub CopyDoc_Ngang1()
Dim Dic2 As Object, Dic3 As Object, Darr, arr()
Dim i As Long, j As Integer, n As Integer, m As Integer, k As Integer
Dim max1 As Integer, max2 As Integer, max3 As Integer, k2 As Integer, k3 As Integer
Set Dic2 = CreateObject("Scripting.Dictionary")
Set Dic3 = CreateObject("Scripting.Dictionary")
Darr = Range("a1:aa" & Range("a2").End(xlDown).Row)
Application.ScreenUpdating = False
Tmp = Darr(2, 1):   max1 = 0
max2 = 0:           max3 = 0
For i = 2 To UBound(Darr)
    If Darr(i, 1) = Tmp Then
        k1 = k1 + 1
        For j = 22 To 24
            If Not Dic2.Exists(Darr(i, j)) Then
                k2 = k2 + 1: Dic2.Add Darr(i, j), ""
                If k2 > max2 Then max2 = k2
            End If
        Next j
        For n = 25 To 27
            If Not Dic3.Exists(Darr(i, n)) Then
                k3 = k3 + 1: Dic3.Add Darr(i, n), ""
                If k3 > max3 Then max3 = k3
            End If
        Next n
    Else
        k1 = 1:      Tmp = Darr(i, 1)
        k2 = 0:     k3 = 0
    End If
    If k1 > max1 Then max1 = k1
Next i
ReDim arr(1 To UBound(Darr), 1 To 16 + max1 * 5 + max2 + max3)
For j = 1 To 16 + max1 * 5
    If j <= 2 Then
        arr(1, j) = Darr(1, j)
    ElseIf j >= 5 * max1 + 3 Then
        arr(1, j) = Darr(1, j - 5 * max1 + 5)
    ElseIf j Mod max1 = 3 Then
        arr(1, j) = Darr(1, Int(j / max1) + 3)
    Else
        arr(1, j) = Darr(1, Int((j - 3) / max1) + 3) & ((j - 3) Mod max1)
    End If
Next j
For j = 1 To max2
    arr(1, j + 16 + max1 * 5) = "TC" & j
Next j
For j = 1 To max3
    arr(1, j + 16 + max1 * 5 + max2) = "NDTC" & j
Next j


k = 1
For i = 2 To UBound(Darr)
    k = k + 1
    arr(k, 1) = Darr(i, 1): arr(k, 2) = Darr(i, 2)
    For j = 5 * max1 + 3 To 5 * max1 + 16
        arr(k, j) = Darr(i, j - 5 * max1 + 5)
    Next j
    cot = 1
    For n = i To UBound(Darr)
        If Darr(n, 1) = Darr(i, 1) Then
            cot = cot + 1
            arr(k, cot + 1) = Darr(n, 3)
            arr(k, cot + 1 + max1) = Darr(n, 4)
            arr(k, cot + 1 + 2 * max1) = Darr(n, 5)
            arr(k, cot + 1 + 3 * max1) = Darr(n, 6)
            arr(k, cot + 1 + 4 * max1) = Darr(n, 7)
            If n = UBound(Darr) Then GoTo thoat
        Else
            i = n - 1
            GoTo tiep
        End If
    Next n
tiep:
Next i
thoat:
For n = 2 To k
    k2 = 5 * max1 + 16: k3 = 5 * max1 + 16 + max2
    Dic2.RemoveAll: Dic3.RemoveAll
    For j = 22 To 27
        For m = 2 To UBound(Darr)
            If arr(n, 1) = Darr(m, 1) Then
                If j <= 24 Then
                    If Not Dic2.Exists(Darr(m, j)) Then
                        Dic2.Add Darr(m, j), ""
                        k2 = k2 + 1
                        arr(n, k2) = Darr(m, j)
                    End If
                Else
                    If Not Dic3.Exists(Darr(m, j)) Then
                        Dic3.Add Darr(m, j), ""
                        k3 = k3 + 1
                        arr(n, k3) = Darr(m, j)
                    End If
                End If
            End If
        Next m
    Next j
Next n
Set Dic2 = Nothing: Set Dic3 = Nothing
Range("af1:dsC" & Range("af65000").End(xlUp).Row).ClearContents
Range("af1").Resize(k, 16 + max1 * 5 + max2 + max3) = arr
Application.ScreenUpdating = True
End Sub
 
diepminhhong đã viết:
Anh HieuCD ơi, Anh có thể giúp e xử lý file này (file đính kèm) với được không ạ? Vẫn là file hôm trước anh làm giúp e nhưng e có thay đổi 1 chút đi. E cảm ơn anh nhiều, Chúc anh sức khỏe và thành công.
Nhấp chuột vào đây để mở rộng...

Chào diepminhhong,

Ôi ghen tị quá đi --=0
Hổng biết bạn có thử code ở bài #2 chưa? (mình trả lời đầu tiên mà vẫn bị cho ra rìa. hức)
Code mình thì kiểu cùi bắp thôi (bạn HieuCD chơi sang dùng tận 2 Dic liền). Bạn thử xem nhé.
(p/s: Có 6 cột cuối thì không hiểu quy luật so với kết quả của bạn: TC1->TC3 mà kết quả cần TC1->TC10)
Sub chính:
PHP: 
Sub Doc2Ngang()
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Sheet1.Range("AF9:ZZ6500").ClearContents
Dim lr As Long, rw As Long, i As Long, m As Long, rc As Long, CV As Long, ii As Long, j As Long
Dim arr, drr(), tmp, cel1 As Range, cel2 As Range
Set cel1 = Sheet1.Range("A1")
Set cel2 = Sheet1.Range("AF1")
lr = cel1.End(xlDown).Row
arr = UniqueArray(Sheet1.Range("A2:A" & lr))
For i = 1 To UBound(arr)
    If arr(i, 1) <> "" Then
        rw = rw + 1
        cel2.Offset(1, 0).Offset(rw - 1).Value = arr(i, 1)
    End If
Next i
ReDim drr(1 To rw)
For i = 1 To rw
    drr(i) = WorksheetFunction.CountIf(Sheet1.Range("A2:A" & lr), arr(i, 1))
Next i
m = Application.Max(drr)
cel2.Value = cel1.Value '// BBS
cel2.Offset(0, 1).Value = cel1.Offset(0, 1).Value '// HM
cel2.Offset(1, 1).Resize(rw, 1) = cel1.Offset(1, 1).Value
'// Tieu de CV->KLNT
For i = 1 To 5
    For j = 1 To m
        rc = rc + 1
        If j = 1 Then cel2.Offset(0, 1).Offset(0, rc) = cel1.Offset(0, 1).Offset(0, i)
        If j > 1 Then cel2.Offset(0, 1).Offset(0, rc) = cel1.Offset(0, 1).Offset(0, i) & j - 1
    Next j
Next i
'// Tieu de GBD->NDTC3
cel2.Offset(0, 5 * m + 2).Resize(1, 20).Value = _
cel1.Offset(0, 7).Resize(1, 20).Value
'// Ghi gia tri:
tmp = cel2.Offset(1).Resize(rw, 1).Value
For i = 1 To UBound(tmp)
    CV = WorksheetFunction.Match(tmp(i, 1), Sheets(1).Range("A1:A" & lr), 0)
    j = 1
    For ii = 1 To (5 * m) Step m
        cel2.Offset(0, 1).Offset(i, ii).Resize(1, drr(i)).Value = _
        Application.Transpose(cel1.Offset(0, 1).Offset(CV - 1, j).Resize(drr(i)))
        j = j + 1
    Next ii
    cel2.Offset(i, 5 * m + 2).Resize(1, 20).Value = _
    cel1.Offset(CV - 1, 7).Resize(1, 20).Value
Next i
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
Còn Function UniqueArray(), bạn chép lại ở bài #2 nhé.
 
befaint đã viết:
bạn HieuCD chơi sang dùng tận 2 Dic liền.
p/s: Có 6 cột cuối thì không hiểu quy luật so với kết quả của bạn: TC1->TC3 mà kết quả cần TC1->TC10
Nhấp chuột vào đây để mở rộng...
dùng 2 Dic để giảm bớt vòng lặp và tăng tốc xử lý
6 cột cuối mới khó xơi, qui luật chia cột tương tự như 5 cột trước không biết trước số cột, nhưng lấy các dòng của nhóm 3 cột và không trùng, và xếp thứ tự từ nhỏ đến lớn. mình không viết lệnh xếp thứ tự mà theo thứ tự có trước
 
HieuCD đã viết:
dùng 2 Dic để giảm bớt vòng lặp và tăng tốc xử lý
6 cột cuối mới khó xơi, qui luật chia cột tương tự như 5 cột trước không biết trước số cột, nhưng lấy các dòng của nhóm 3 cột và không trùng, và xếp thứ tự từ nhỏ đến lớn. mình không viết lệnh xếp thứ tự mà theo thứ tự có trước
Nhấp chuột vào đây để mở rộng...
Đã xem lại và rõ quy luật của 2 nhóm TC và NDTC. Cảm ơn HieuCD.
Số lượng phần tử TC = max (số giá trị không lặp lại của nhóm TC ứng với mỗi BBS) và tương tự với nhóm NDTC.
Theo kết quả đã cho thì quy luật xếp giá trị vào tương ứng với các phần tử của nhóm (ứng với mỗi BBS) lấy theo cột (đã loại trùng) từ trái sang phải rồi xoay thành hàng.
 
HieuCD đã viết:
bạn kiể tra lại code
Mã: 
Sub CopyDoc_Ngang1()
Dim Dic2 As Object, Dic3 As Object, Darr, arr()
Dim i As Long, j As Integer, n As Integer, m As Integer, k As Integer
Dim max1 As Integer, max2 As Integer, max3 As Integer, k2 As Integer, k3 As Integer
Set Dic2 = CreateObject("Scripting.Dictionary")
Set Dic3 = CreateObject("Scripting.Dictionary")
Darr = Range("a1:aa" & Range("a2").End(xlDown).Row)
Application.ScreenUpdating = False
Tmp = Darr(2, 1):   max1 = 0
max2 = 0:           max3 = 0
For i = 2 To UBound(Darr)
    If Darr(i, 1) = Tmp Then
        k1 = k1 + 1
        For j = 22 To 24
            If Not Dic2.Exists(Darr(i, j)) Then
                k2 = k2 + 1: Dic2.Add Darr(i, j), ""
                If k2 > max2 Then max2 = k2
            End If
        Next j
        For n = 25 To 27
            If Not Dic3.Exists(Darr(i, n)) Then
                k3 = k3 + 1: Dic3.Add Darr(i, n), ""
                If k3 > max3 Then max3 = k3
            End If
        Next n
    Else
        k1 = 1:      Tmp = Darr(i, 1)
        k2 = 0:     k3 = 0
    End If
    If k1 > max1 Then max1 = k1
Next i
ReDim arr(1 To UBound(Darr), 1 To 16 + max1 * 5 + max2 + max3)
For j = 1 To 16 + max1 * 5
    If j <= 2 Then
        arr(1, j) = Darr(1, j)
    ElseIf j >= 5 * max1 + 3 Then
        arr(1, j) = Darr(1, j - 5 * max1 + 5)
    ElseIf j Mod max1 = 3 Then
        arr(1, j) = Darr(1, Int(j / max1) + 3)
    Else
        arr(1, j) = Darr(1, Int((j - 3) / max1) + 3) & ((j - 3) Mod max1)
    End If
Next j
For j = 1 To max2
    arr(1, j + 16 + max1 * 5) = "TC" & j
Next j
For j = 1 To max3
    arr(1, j + 16 + max1 * 5 + max2) = "NDTC" & j
Next j


k = 1
For i = 2 To UBound(Darr)
    k = k + 1
    arr(k, 1) = Darr(i, 1): arr(k, 2) = Darr(i, 2)
    For j = 5 * max1 + 3 To 5 * max1 + 16
        arr(k, j) = Darr(i, j - 5 * max1 + 5)
    Next j
    cot = 1
    For n = i To UBound(Darr)
        If Darr(n, 1) = Darr(i, 1) Then
            cot = cot + 1
            arr(k, cot + 1) = Darr(n, 3)
            arr(k, cot + 1 + max1) = Darr(n, 4)
            arr(k, cot + 1 + 2 * max1) = Darr(n, 5)
            arr(k, cot + 1 + 3 * max1) = Darr(n, 6)
            arr(k, cot + 1 + 4 * max1) = Darr(n, 7)
            If n = UBound(Darr) Then GoTo thoat
        Else
            i = n - 1
            GoTo tiep
        End If
    Next n
tiep:
Next i
thoat:
For n = 2 To k
    k2 = 5 * max1 + 16: k3 = 5 * max1 + 16 + max2
    Dic2.RemoveAll: Dic3.RemoveAll
    For j = 22 To 27
        For m = 2 To UBound(Darr)
            If arr(n, 1) = Darr(m, 1) Then
                If j <= 24 Then
                    If Not Dic2.Exists(Darr(m, j)) Then
                        Dic2.Add Darr(m, j), ""
                        k2 = k2 + 1
                        arr(n, k2) = Darr(m, j)
                    End If
                Else
                    If Not Dic3.Exists(Darr(m, j)) Then
                        Dic3.Add Darr(m, j), ""
                        k3 = k3 + 1
                        arr(n, k3) = Darr(m, j)
                    End If
                End If
            End If
        Next m
    Next j
Next n
Set Dic2 = Nothing: Set Dic3 = Nothing
Range("af1:dsC" & Range("af65000").End(xlUp).Row).ClearContents
Range("af1").Resize(k, 16 + max1 * 5 + max2 + max3) = arr
Application.ScreenUpdating = True
End Sub
Nhấp chuột vào đây để mở rộng...
Vâng, em cảm ơn anh nhiều ạ. E chúc anh sức khỏe và thành công ạ!
 
befaint đã viết:
Chào diepminhhong,

Ôi ghen tị quá đi --=0
Hổng biết bạn có thử code ở bài #2 chưa? (mình trả lời đầu tiên mà vẫn bị cho ra rìa. hức)
Code mình thì kiểu cùi bắp thôi (bạn HieuCD chơi sang dùng tận 2 Dic liền). Bạn thử xem nhé.
(p/s: Có 6 cột cuối thì không hiểu quy luật so với kết quả của bạn: TC1->TC3 mà kết quả cần TC1->TC10)
Sub chính:
PHP: 
Sub Doc2Ngang()
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Sheet1.Range("AF9:ZZ6500").ClearContents
Dim lr As Long, rw As Long, i As Long, m As Long, rc As Long, CV As Long, ii As Long, j As Long
Dim arr, drr(), tmp, cel1 As Range, cel2 As Range
Set cel1 = Sheet1.Range("A1")
Set cel2 = Sheet1.Range("AF1")
lr = cel1.End(xlDown).Row
arr = UniqueArray(Sheet1.Range("A2:A" & lr))
For i = 1 To UBound(arr)
    If arr(i, 1) <> "" Then
        rw = rw + 1
        cel2.Offset(1, 0).Offset(rw - 1).Value = arr(i, 1)
    End If
Next i
ReDim drr(1 To rw)
For i = 1 To rw
    drr(i) = WorksheetFunction.CountIf(Sheet1.Range("A2:A" & lr), arr(i, 1))
Next i
m = Application.Max(drr)
cel2.Value = cel1.Value '// BBS
cel2.Offset(0, 1).Value = cel1.Offset(0, 1).Value '// HM
cel2.Offset(1, 1).Resize(rw, 1) = cel1.Offset(1, 1).Value
'// Tieu de CV->KLNT
For i = 1 To 5
    For j = 1 To m
        rc = rc + 1
        If j = 1 Then cel2.Offset(0, 1).Offset(0, rc) = cel1.Offset(0, 1).Offset(0, i)
        If j > 1 Then cel2.Offset(0, 1).Offset(0, rc) = cel1.Offset(0, 1).Offset(0, i) & j - 1
    Next j
Next i
'// Tieu de GBD->NDTC3
cel2.Offset(0, 5 * m + 2).Resize(1, 20).Value = _
cel1.Offset(0, 7).Resize(1, 20).Value
'// Ghi gia tri:
tmp = cel2.Offset(1).Resize(rw, 1).Value
For i = 1 To UBound(tmp)
    CV = WorksheetFunction.Match(tmp(i, 1), Sheets(1).Range("A1:A" & lr), 0)
    j = 1
    For ii = 1 To (5 * m) Step m
        cel2.Offset(0, 1).Offset(i, ii).Resize(1, drr(i)).Value = _
        Application.Transpose(cel1.Offset(0, 1).Offset(CV - 1, j).Resize(drr(i)))
        j = j + 1
    Next ii
    cel2.Offset(i, 5 * m + 2).Resize(1, 20).Value = _
    cel1.Offset(CV - 1, 7).Resize(1, 20).Value
Next i
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
Còn Function UniqueArray(), bạn chép lại ở bài #2 nhé.
Nhấp chuột vào đây để mở rộng...

Anh befaint ơi, Code ở bài 2 e cũng thử rồi anh ạ. Cũng ok anh ạ. Và cả code xóa trắng bảng số liệu trong Word anh gửi cho e nữa, e đã thử và làm được rồi. E cảm ơn anh nhiều nhé! Đừng ghen tị chứ vì diễn đàn có những người như anh HieuCD và anh befaint thì những người yếu về excel như bọn e đây được nhờ nhiều lắm anh ạ. E chúc a sức khỏe nhiều để công tác tốt nhé!
 
befaint đã viết:
Đã xem lại và rõ quy luật của 2 nhóm TC và NDTC. Cảm ơn HieuCD.
Số lượng phần tử TC = max (số giá trị không lặp lại của nhóm TC ứng với mỗi BBS) và tương tự với nhóm NDTC.
Theo kết quả đã cho thì quy luật xếp giá trị vào tương ứng với các phần tử của nhóm (ứng với mỗi BBS) lấy theo cột (đã loại trùng) từ trái sang phải rồi xoay thành hàng.
Nhấp chuột vào đây để mở rộng...
TC1, TC2, TC3 của em bên cột dọc ứng với mỗi công việc có thể giống nhau, có thể khác nhau. Mỗi TC thì ứng với 1 nội dung. Khi copy chuyển sang ngang thì e cũng muốn chuyển các TC sang hàng ngang và ứng với nó là các NDTC Nhưng các công việc mà có TC giống nhau thì khi copy sang hàng ngang thì mình loại bỏ cái TC giống nhau đi(giả sử có 3 TC giống nhau thì chỉ lấy 1 TC thôi còn 2 cái giống còn lại thì bỏ đi. NDTC cũng vậy anh ạ).
 
HieuCD đã viết:
bạn kiể tra lại code
Mã: 
Sub CopyDoc_Ngang1()
Dim Dic2 As Object, Dic3 As Object, Darr, arr()
Dim i As Long, j As Integer, n As Integer, m As Integer, k As Integer
Dim max1 As Integer, max2 As Integer, max3 As Integer, k2 As Integer, k3 As Integer
Set Dic2 = CreateObject("Scripting.Dictionary")
Set Dic3 = CreateObject("Scripting.Dictionary")
Darr = Range("a1:aa" & Range("a2").End(xlDown).Row)
Application.ScreenUpdating = False
Tmp = Darr(2, 1):   max1 = 0
max2 = 0:           max3 = 0
For i = 2 To UBound(Darr)
    If Darr(i, 1) = Tmp Then
        k1 = k1 + 1
        For j = 22 To 24
            If Not Dic2.Exists(Darr(i, j)) Then
                k2 = k2 + 1: Dic2.Add Darr(i, j), ""
                If k2 > max2 Then max2 = k2
            End If
        Next j
        For n = 25 To 27
            If Not Dic3.Exists(Darr(i, n)) Then
                k3 = k3 + 1: Dic3.Add Darr(i, n), ""
                If k3 > max3 Then max3 = k3
            End If
        Next n
    Else
        k1 = 1:      Tmp = Darr(i, 1)
        k2 = 0:     k3 = 0
    End If
    If k1 > max1 Then max1 = k1
Next i
ReDim arr(1 To UBound(Darr), 1 To 16 + max1 * 5 + max2 + max3)
For j = 1 To 16 + max1 * 5
    If j <= 2 Then
        arr(1, j) = Darr(1, j)
    ElseIf j >= 5 * max1 + 3 Then
        arr(1, j) = Darr(1, j - 5 * max1 + 5)
    ElseIf j Mod max1 = 3 Then
        arr(1, j) = Darr(1, Int(j / max1) + 3)
    Else
        arr(1, j) = Darr(1, Int((j - 3) / max1) + 3) & ((j - 3) Mod max1)
    End If
Next j
For j = 1 To max2
    arr(1, j + 16 + max1 * 5) = "TC" & j
Next j
For j = 1 To max3
    arr(1, j + 16 + max1 * 5 + max2) = "NDTC" & j
Next j


k = 1
For i = 2 To UBound(Darr)
    k = k + 1
    arr(k, 1) = Darr(i, 1): arr(k, 2) = Darr(i, 2)
    For j = 5 * max1 + 3 To 5 * max1 + 16
        arr(k, j) = Darr(i, j - 5 * max1 + 5)
    Next j
    cot = 1
    For n = i To UBound(Darr)
        If Darr(n, 1) = Darr(i, 1) Then
            cot = cot + 1
            arr(k, cot + 1) = Darr(n, 3)
            arr(k, cot + 1 + max1) = Darr(n, 4)
            arr(k, cot + 1 + 2 * max1) = Darr(n, 5)
            arr(k, cot + 1 + 3 * max1) = Darr(n, 6)
            arr(k, cot + 1 + 4 * max1) = Darr(n, 7)
            If n = UBound(Darr) Then GoTo thoat
        Else
            i = n - 1
            GoTo tiep
        End If
    Next n
tiep:
Next i
thoat:
For n = 2 To k
    k2 = 5 * max1 + 16: k3 = 5 * max1 + 16 + max2
    Dic2.RemoveAll: Dic3.RemoveAll
    For j = 22 To 27
        For m = 2 To UBound(Darr)
            If arr(n, 1) = Darr(m, 1) Then
                If j <= 24 Then
                    If Not Dic2.Exists(Darr(m, j)) Then
                        Dic2.Add Darr(m, j), ""
                        k2 = k2 + 1
                        arr(n, k2) = Darr(m, j)
                    End If
                Else
                    If Not Dic3.Exists(Darr(m, j)) Then
                        Dic3.Add Darr(m, j), ""
                        k3 = k3 + 1
                        arr(n, k3) = Darr(m, j)
                    End If
                End If
            End If
        Next m
    Next j
Next n
Set Dic2 = Nothing: Set Dic3 = Nothing
Range("af1:dsC" & Range("af65000").End(xlUp).Row).ClearContents
Range("af1").Resize(k, 16 + max1 * 5 + max2 + max3) = arr
Application.ScreenUpdating = True
End Sub
Nhấp chuột vào đây để mở rộng...

Anh HieuCD ơi, code anh gửi cho em thì nếu chạy cái file e tải lên thì chạy được còn nếu chạy file khác hoặc thêm dòng ngang ở phía dưới ( nghĩa là ở cột BBS không phải là tới 4 mà có thể là vài trăm chẳng hạn) thì nó báo lỗi Run-time error '9'. Sau đó em kích vào chứ debug thì nó hiện code lên và bôi vàng dòng "arr(n, k3) = Darr(m, j) ". E chẳng hiểu mô tê gì. Anh có thể giúp em với được không ạ. E cảm ơn nhiều ạ. (E có file đính kèm phía dưới đấy ạ).
 

File đính kèm

Bạn phải đăng nhập hoặc đăng ký để trả lời bài viết tại đây.
Web KT

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

C
  • Question Question
Xin hỏi Cách viết chú thích trong vba hiển thị tiếng việt
Trả lời
4
Đọc
130
ongke0711
ongke0711
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. (1 người xem)
    • Thích
2
Trả lời
28
Đọc
7K
Hoàng Tuấn 868
H
G
Xin Code xóa Module.
Trả lời
8
Đọc
273
huhumalu
H
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
3
Đọc
146
tle2003
T
D
  • Đã giải quyết
Quản lý email outlook qua VBA cần giúp đỡ
2
Trả lời
22
Đọc
545
nguyendang95
N
S
Mở 2 cửa sổ riêng biệt
2
Trả lời
30
Đọc
23K
sakuraluu
S
F
Nhập dấu . (chấm) ở bàn phím phụ không tự chuyển thành dấu , (phẩy)
Trả lời
16
Đọc
57K
tubaodn21
tubaodn21
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
138
lamvu0677
L
N
Khắc phục lỗi "The picture is too large and will be truncated" (1 người xem)
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
2K
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
123
khkkh
K
K
Xin dax tính tỷ trọng doanh thu
Trả lời
18
Đọc
798
SteveNguyen1991
S
F
  • Question Question
Tự động Merge Mail bằng VBA
Trả lời
6
Đọc
228
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
148
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
138
HieuCD
H
BNTT
LockXLS - Chương trình bảo vệ an toàn cho các file bảng tính Excel (1 người xem)
    • 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
223
thuytrangbp28
T
micam111
  • Question Question
Cách chạy nhiều đồng hồ đếm giờ trong VBA
Trả lời
4
Đọc
712
thuytrangbp28
T
Emyeuexcel
  • Question Question
In tất cả các file trong cùng 1 thư mục
Trả lời
3
Đọc
241
Hoàng Tuấn 868
H
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