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

diepminhhong đã viết:
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 ạ).
Nhấp chuột vào đây để mở rộng...
bạn thêm đoạn code màu đỏ vào
Mã: 
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) [COLOR=#ff0000]And Darr(m, j) <>[/COLOR] [COLOR=#ff0000]""[/COLOR] 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, 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 ạ).
Nhấp chuột vào đây để mở rộng...

Chào diepminhhong,

Góp ý với bạn, lần sau trích dẫn bài của ai đó để trả lời thì bạn chỉ cần trích dẫn phần cần thiết, phần cần lưu tâm tới, không nên trích dẫn nguyên cả bài (nhất là bài chứa code dài như trên) dẫn đến kéo dài trang, khó xem.
Nếu không cần trích dẫn thì bạn có thể bắt đầu bài viết của mình muốn nói với một hoặc nhiều người thì viết vầy:
"Chào một ai đó" hoặc "Gửi một ai đó"
"Chào người một, người thứ hai..."
Thân,
 
befaint đã viết:
Chào diepminhhong,

Góp ý với bạn, lần sau trích dẫn bài của ai đó để trả lời thì bạn chỉ cần trích dẫn phần cần thiết, phần cần lưu tâm tới, không nên trích dẫn nguyên cả bài (nhất là bài chứa code dài như trên) dẫn đến kéo dài trang, khó xem.
Nếu không cần trích dẫn thì bạn có thể bắt đầu bài viết của mình muốn nói với một hoặc nhiều người thì viết vầy:
"Chào một ai đó" hoặc "Gửi một ai đó"
"Chào người một, người thứ hai..."
Thân,
Nhấp chuột vào đây để mở rộng...
Vâng ạ, e cảm ơn anh befaint đã góp ý cho e ạ. E cũng là thành viên mới có gì chưa đúng với nội quy của diễn đàn các anh chỉ bảo giúp e ạ.
 
HieuCD đã viết:
bạn thêm đoạn code màu đỏ vào
Mã: 
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) [COLOR=#ff0000]And Darr(m, j) <>[/COLOR] [COLOR=#ff0000]""[/COLOR] 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 ơi không hiểu sao e chạy code đó vào file của em thì vẫn báo lỗi. File của em có tất cả số BBS là 81 nhưng e chạy code chỉ được tới BBS 62 thôi. Còn chạy tới BBS 63 trở đi thì lại bị lỗi. Từ BBS 63 trở đi thì cái được cái thì bị lỗi (vì em ngồi dò thủ công từng BBS một nên e thấy như vậy). E có gửi file đính kèm, anh có thể kiểm tra giúp e với được không ạ. E biết e hỏi hơi nhiều, nhưng thực sự e không biết gì về phần code này cả. Mong anh thông cảm ạ.
 

File đính kèm

diepminhhong đã viết:
Anh ơi không hiểu sao e chạy code đó vào file của em thì vẫn báo lỗi. File của em có tất cả số BBS là 81 nhưng e chạy code chỉ được tới BBS 62 thôi. Còn chạy tới BBS 63 trở đi thì lại bị lỗi. Từ BBS 63 trở đi thì cái được cái thì bị lỗi (vì em ngồi dò thủ công từng BBS một nên e thấy như vậy). E có gửi file đính kèm, anh có thể kiểm tra giúp e với được không ạ. E biết e hỏi hơi nhiều, nhưng thực sự e không biết gì về phần code này cả. Mong anh thông cảm ạ.
Nhấp chuột vào đây để mở rộng...
bạn kiểm 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)) And 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)) And 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
        Dic2.RemoveAll: Dic3.RemoveAll
        For j = 22 To 24
            If Not Dic2.Exists(Darr(i, j)) And 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)) And Darr(i, n) <> "" Then
                k3 = k3 + 1: Dic3.Add Darr(i, n), ""
                If k3 > max3 Then max3 = k3
            End If
        Next n
    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) And Darr(m, j) <> "" Then
                If j <= 24 Then
                    If Not Dic2.Exists(Darr(m, j)) And 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)) And 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("ac1:hh" & Range("ac65000").End(xlUp).Row).ClearContents
Range("ac1").Resize(k, 16 + max1 * 5 + max2 + max3) = arr
Application.ScreenUpdating = True
End Sub
 
diepminhhong đã viết:
HieuCD đã viết:
bạn kiểm tra lại code
Anh HieuCD ơi, Anh có thể xem lại giúp em file này với được k ạ? (file đính kèm). E cảm ơn anh ạ
Nhấp chuột vào đây để mở rộng...
như vậy là lúc nào cũng có 16 cột CV? code sẽ đơn giản hơn nhiều
các cột cuối TC và NDTC có qui định số cột không? hay lấy vừa đủ?
bạn cho biết và sáng mai mình sẽ viết code lại, đơn giản hơn nhiều
Nhấp chuột vào đây để mở rộng...
 
HieuCD đã viết:
diepminhhong đã viết:
như vậy là lúc nào cũng có 16 cột CV? code sẽ đơn giản hơn nhiều
các cột cuối TC và NDTC có qui định số cột không? hay lấy vừa đủ?
bạn cho biết và sáng mai mình sẽ viết code lại, đơn giản hơn nhiều
Nhấp chuột vào đây để mở rộng...
Vâng ạ. Khi chuyển sang hàng ngang thì dù số BBS có nhiều hay ít thì khi chuyển sang hàng ngang thì lúc nào cũng phải có từ CV, CV1 tới CV15 tương ứng là ĐV, KLTK, KLTC, KLNT(Code đầu tiên anh gửi cho e là anh viết như thế). Còn cột TC và NDTC thì chỉ cần tới 10 thôi ạ. Tức là TC1....TC10 và NDTC1.... tới NDTC10. Cột TC và NDTC thì TC1 tương ứng với NDTC1, TC2 tương ứng với NDTC2...... và loại bỏ trùng nhau. E làm tới 10 để phòng thôi chứ thực ra chỉ tới 6 là nhiều rồi anh ạ. Tóm lại cái cột TC với NDTC đấy anh viết sao cũng được chỉ cần TC1 tương ứng với NDTC1........ và loại bỏ trùng nhau thôi ạ.
Nhấp chuột vào đây để mở rộng...
 
diepminhhong đã viết:
HieuCD đã viết:
Vâng ạ. Khi chuyển sang hàng ngang thì dù số BBS có nhiều hay ít thì khi chuyển sang hàng ngang thì lúc nào cũng phải có từ CV, CV1 tới CV15 tương ứng là ĐV, KLTK, KLTC, KLNT(Code đầu tiên anh gửi cho e là anh viết như thế). Còn cột TC và NDTC thì chỉ cần tới 10 thôi ạ. Tức là TC1....TC10 và NDTC1.... tới NDTC10. Cột TC và NDTC thì TC1 tương ứng với NDTC1, TC2 tương ứng với NDTC2...... và loại bỏ trùng nhau. E làm tới 10 để phòng thôi chứ thực ra chỉ tới 6 là nhiều rồi anh ạ. Tóm lại cái cột TC với NDTC đấy anh viết sao cũng được chỉ cần TC1 tương ứng với NDTC1........ và loại bỏ trùng nhau thôi ạ.
Nhấp chuột vào đây để mở rộng...

Vậy thì bạn còn chưa nắm được quy luật tạo ra số lượng CV.
Số lượng CV = max (count BBS(i) trong BBS)
Còn số lượng nhóm TC và NDTC như tôi đã diễn đạt lại theo hướng dẫn của HieuCD ở bài #18.
Nhấp chuột vào đây để mở rộng...
 
befaint đã viết:
diepminhhong đã viết:
Vậy thì bạn còn chưa nắm được quy luật tạo ra số lượng CV.
Số lượng CV = max (count BBS(i) trong BBS)
Còn số lượng nhóm TC và NDTC như tôi đã diễn đạt lại theo hướng dẫn của HieuCD ở bài #18.
Nhấp chuột vào đây để mở rộng...

Cái đó thì e biết rồi anh befaint ạ. Sở dĩ e muốn cái nào cũng là 16 là vì nó liên quan tới 1 file sau này của e. E để mặc định nó là 16 rồi. file đó = max số BBS anh ạ. Vì phần code em k biết gì nên khó chỉnh sửa nên e phải để vậy. Mong các anh giúp đỡ.
Nhấp chuột vào đây để mở rộng...
 
diepminhhong đã viết:
Vâng ạ. Khi chuyển sang hàng ngang thì dù số BBS có nhiều hay ít thì khi chuyển sang hàng ngang thì lúc nào cũng phải có từ CV, CV1 tới CV15 tương ứng là ĐV, KLTK, KLTC, KLNT(Code đầu tiên anh gửi cho e là anh viết như thế). Còn cột TC và NDTC thì chỉ cần tới 10 thôi ạ. Tức là TC1....TC10 và NDTC1.... tới NDTC10. Cột TC và NDTC thì TC1 tương ứng với NDTC1, TC2 tương ứng với NDTC2...... và loại bỏ trùng nhau. E làm tới 10 để phòng thôi chứ thực ra chỉ tới 6 là nhiều rồi anh ạ. Tóm lại cái cột TC với NDTC đấy anh viết sao cũng được chỉ cần TC1 tương ứng với NDTC1........ và loại bỏ trùng nhau thôi ạ.
Nhấp chuột vào đây để mở rộng...
code chạy với số cột cố định, khi cần thay đổi thì bạn khai báo lại số cột trong code
Mã: 
Sub CopyDoc_Ngang()
Dim Dic As Object, Darr, arr()
Dim i As Long, n As Long, m As Long, j As Integer, k As Integer, k2 As Integer, Scot1 As Integer, Scot2 As Integer
Set Dic = CreateObject("Scripting.Dictionary")
Darr = Range("a1:aa" & Range("a1").End(xlDown).Row)
Application.ScreenUpdating = False
Scot1 = 16  'so cot NV
Scot2 = 6   'so cot TC. Khi can thay doi thi dieu chinh cac so cot lai
ReDim arr(1 To UBound(Darr), 1 To 16 + 5 * Scot1 + 2 * Scot2)   'tong cot la 108=16+5*16+2*6
'tao tieu de cot
For j = 1 To 16 + 5 * Scot1
    If j <= 2 Then
        arr(1, j) = Darr(1, j)
    ElseIf j >= 5 * Scot1 + 3 Then
        arr(1, j) = Darr(1, j - 5 * Scot1 + 5)
    ElseIf j Mod Scot1 = 3 Then
        arr(1, j) = Darr(1, Int(j / Scot1) + 3)
    Else
        arr(1, j) = Darr(1, Int((j - 3) / Scot1) + 3) & ((j - 3) Mod Scot1)
    End If
Next j
For j = 1 To Scot2
    arr(1, j + 16 + Scot1 * 5) = "TC" & j
    arr(1, j + 16 + Scot1 * 5 + Scot2) = "NDTC" & j
Next j
'Lay du lieu toi cot Nam1
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 * Scot1 + 3 To 5 * Scot1 + 16
        arr(k, j) = Darr(i, j - 5 * Scot1 + 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 + Scot1) = Darr(n, 4)
            arr(k, cot + 1 + 2 * Scot1) = Darr(n, 5)
            arr(k, cot + 1 + 3 * Scot1) = Darr(n, 6)
            arr(k, cot + 1 + 4 * Scot1) = Darr(n, 7)
            If n = UBound(Darr) Then GoTo thoat
        Else
            i = n - 1
            GoTo tiep
        End If
    Next n
tiep:
Next i
thoat:
'Lay du lieu  cot TC va NDTC
For n = 2 To k
    k2 = 5 * Scot1 + 16
    Dic.RemoveAll
    For j = 22 To 24
        For m = 2 To UBound(Darr)
            If arr(n, 1) = Darr(m, 1) And Darr(m, j) <> "" Then
                If Not Dic.Exists(Darr(m, j)) And Darr(m, j) <> "" Then
                    Dic.Add Darr(m, j), ""
                    k2 = k2 + 1
                    arr(n, k2) = Darr(m, j)
                    arr(n, k2 + Scot2) = Darr(m, j + 3)
                End If
            End If
        Next m
    Next j
Next n
Set Dic = Nothing
Range("ac1:en" & Range("ac65000").End(xlUp).Row).Clear
Range("ac1").Resize(k, 16 + Scot1 * 5 + 2 * Scot2) = arr
Range("ac1").Resize(k, 16 + Scot1 * 5 + 2 * Scot2).Borders.LineStyle = 1
Application.ScreenUpdating = True
End Sub
 
Lần chỉnh sửa cuối:
diepminhhong đã viết:
Cái đó thì e biết rồi anh befaint ạ. Sở dĩ e muốn cái nào cũng là 16 là vì nó liên quan tới 1 file sau này của e. E để mặc định nó là 16 rồi. file đó = max số BBS anh ạ. Vì phần code em k biết gì nên khó chỉnh sửa nên e phải để vậy. Mong các anh giúp đỡ.
Nhấp chuột vào đây để mở rộng...
Chào diepminhhong,

Tôi viết code cho trường hợp số BBS, số TC/ NDTC là tuỳ dữ liệu nhập vào (theo cấu trúc File của bạn).
Số dòng trong Sub chính cũng gần bằng bài #33 nhưng lại dùng thêm 4 Function --=0--=0
Mời bạn xem file.
 

File đính kèm

befaint đã viết:
Chào diepminhhong,

Tôi viết code cho trường hợp số BBS, số TC/ NDTC là tuỳ dữ liệu nhập vào (theo cấu trúc File của bạn).
Số dòng trong Sub chính cũng gần bằng bài #33 nhưng lại dùng thêm 4 Function --=0--=0
Mời bạn xem file.
Nhấp chuột vào đây để mở rộng...
E cảm ơn anh befaint. Hôm nay đi làm e mới vào diễn đàn và đọc được bài của anh. E đang down về thử xem sao. Cảm ơn anh nhiều nhé.
 
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

S
Em muốn copy các dữ liệu ô họ tên đã bị gộp từ B9 đến E9. Em muốn pass sang ô B9 (sheet mới). Thank (1 người xem)
Trả lời
4
Đọc
47
samthai8017
S
S
Xin các Pro chia sẻ giúp
Trả lời
4
Đọc
48
samthai8017
S
GPE-Trợ Lý
TALKSHOW 16 BẬT MÍ THỦ THUẬT GOOGLE SHEET: TỔNG HỢP DỮ LIỆU TỪ NHIỀU SHEET & FILE BĂNG IMPORTRANGE (2 người xem)
Trả lời
1
Đọc
473
GPE-Trợ Lý
GPE-Trợ Lý
T
  • Question Question
Kết quả lọc dữ liệu từ sheet TONG HOP qua từng chi tiết (1 người xem)
Trả lời
0
Đọc
15
truc l
T
B
Em nhờ các bro giúp giải pháp in nhiều file ạ (2 người xem)
Trả lời
3
Đọc
56
Hoàng Tuấn 868
H
T
  • Question Question
Code VBA tra cứu kết quả trả về mảng dữ liệu
    • Cười
Trả lời
17
Đọc
321
LOGANWover
L
HeSanbi
  • Question Question
VBScript.RegExp sẽ bị xóa khỏi Windows: thư viện Pcre2 giải pháp thay thế tối ưu
    • Thích
    • Cảm ơn
Trả lời
1
Đọc
70
HeSanbi
HeSanbi
S
Xin hỏi các pro. Em muốn copy các dữ liệu ô họ tên đã bị gộp từ B9 đến E9. Em muốn pass sang ô B9 (sheet mới). (1 người xem)
Trả lời
3
Đọc
59
samthai8017
S
T
Nhờ anh chị tìm giúp nguyên nhân không nhảy dữ liệu Pivotable
Trả lời
2
Đọc
65
thuhacoicoi
T
HeSanbi
  • Question Question
Chuyển mã VBA ứng dụng Excel 32 bit hoạt động trên cả 64bit (Hoàn toàn 0 phí)
    • Thích
Trả lời
0
Đọc
57
HeSanbi
HeSanbi
T
Ctrl + Shift + 0 không dùng để unhide cột được
Trả lời
24
Đọc
22K
Oji
O
quangminhici
Tặng Addin Word xuất Mail Merge có chức năng cắt ra nhiều file và gửi mail.
    • Thích
    • Yêu thích
Trả lời
19
Đọc
4K
Hoàng Tuấn 868
H
Gà Công Nghệ
Nhờ anh chị chuyển hộ font chữ excel
Trả lời
3
Đọc
95
HeSanbi
HeSanbi
huytamlinh
Anh Chị giúp em sửa lỗi định dạng với ạ ! (1 người xem)
Trả lời
3
Đọc
47
Hoàng Tuấn 868
H
T
  • Question Question
Xin giúp em mã lệnh tổng hợp tự động lên bảng tổng hợp! (1 người xem)
Trả lời
1
Đọc
57
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
4
Đọc
922
nguyendang95
N
V
Quản lý xuất nhập vật tư trong kho
Trả lời
19
Đọc
765
LOGANWover
L
phuongnam366377
Học C++ từ số 0 – Bài học đầu tiên
    • Cảm ơn
Trả lời
4
Đọc
356
phuongnam366377
phuongnam366377
F
Mấy cao thủ giúp dùm mình với. File excel bị lỗi mà mình không biết lỗi chỗ nào để sửa.
Trả lời
2
Đọc
113
firstbood
F
ongke0711
  • Question Question
Tải hóa đơn điện tử (https://hoadondientu.gdt.gov.vn/) Excel Vba
    • Thích
    • Yêu thích
    • Cảm ơn
3 4 5
Trả lời
438
Đọc
59K
sát thủ uyên ương
S
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