Lấy dữ liệu sang sheet khác

Liên hệ QC
vova2209

vova2209

Thành viên tích cực
Tham gia
5/4/17
Bài viết
835
Được thích
112
Giới tính
Nam
Nghề nghiệp
Đường bộ
Chào anh chị!
Nhờ anh chị giúp đỡ em sử lý số liệu như hình dưới đây:
1. Trong sheet"Doan 2" Lấy tên công việc từ cột A thống kê ra cột H (đặt lần lượt alpha B)
)
2. Copy tên công việc ở Sheet"Doan 2" cột H paste sang sheet"THKL" đặt từ cột F2 đến G2, H2...
3. Copy tên cọc từ cột A ở Sheet"Doan 2" paste sang sheet"THKL" cột D4 đến D..
4. Copy số tách từ Km+9.97 cột A ở Sheet"Doan 2" paste sang sheet"THKL" cột E5 đến D..
5. Copy số ứng với công việc từ cột C ở Sheet"Doan 2" paste sang sheet"THKL". VD tìm được "Đào khuôn đất c3" 4.37 copy sang sheet"THTL" đặt vào cột i
Em xin cảm ơn!

Untitled.png
 

File đính kèm

  • KLTH.xlsm
    72.7 KB · Đọc: 15
Lần chỉnh sửa cuối:
Sắp xếp theo thời gian sắp xếp theo bầu chọn
vova2209 đã viết:
Chào anh chị!
Nhờ anh chị giúp đỡ em sử lý số liệu như hình dưới đây:
1. Trong sheet"Doan 2" Lấy tên công việc từ cột A thống kê ra cột H (đặt lần lượt alpha B)
)
2. Copy tên công việc ở Sheet"Doan 2" cột H paste sang sheet"THKL" đặt từ cột F2 đến G2, H2...
3. Copy tên cọc từ cột A ở Sheet"Doan 2" paste sang sheet"THKL" cột D4 đến D..
4. Copy số tách từ Km+9.97 cột A ở Sheet"Doan 2" paste sang sheet"THKL" cột E5 đến D..
5. Copy số ứng với công việc từ cột C ở Sheet"Doan 2" paste sang sheet"THKL". VD tìm được "Đào khuôn đất c3" 4.37 copy sang sheet"THTL" đặt vào cột i
Em xin cảm ơn!

View attachment 265098
Nhấp chuột vào đây để mở rộng...
Bạn thử code cùi bắp này xem sao.
Mã: 
Sub XYZ()
Dim i&, j&, Lr&, R&, k&, t&, Z&
Dim Arr(), KQ()

With Sheet1
Lr = .Cells(Rows.Count, 1).End(xlUp).Row
Arr = .Range("A2:c" & Lr).Value
End With

R = UBound(Arr)
ReDim KQ(1 To R, 1 To 9)
For i = 1 To UBound(Arr)
    If Left(Arr(i, 1), 2) = "Km" Then
        k = k + 1
        Z = k * 2 - 1
        KQ(Z, 1) = Arr(i, 1)
        KQ(Z, 2) = k '- 1
        KQ(Z + 1, 3) = Mid(Arr(i, 1), 5, Len(Arr(i, 1)) - 4)
    Else
        If Left(Trim(Arr(i, 1)), 2) = "Km" Or Left(Trim(Arr(i, 1)), 1) = "C" Or Left(Trim(Arr(i, 1)), 1) = "V" Then
            Else
            DK = Trim(Arr(i, 1))
            If DK = "§¾p nÒn" Then t = 4
            If DK = "§µo ®Êt c3" Then t = 5
            If DK = "§µo r·nh ®Êt c3" Then t = 6
            If DK = "§µo khu«n ®Êt c3" Then t = 7
            If DK = "B mÆt ®êng" Then t = 8
            If DK = "L chiÕm dông" Then t = 9
               KQ(Z + 1, t) = Arr(i, 3)
        End If
    End If
Next i
Sheets("KLTH").[C4].Resize(k, 9) = KQ
End Sub
Tôi là luôn phần tổng hợp sang Sh KLTH. Hy vọng đúng ý.
Hãy thêm hoặc thay đổi dữ liệu và nhấn nút CHAY CODE ở Sh KLTH để xem và kiểm tra kết quả
Rất mong anh chị em trên diễn đàn ghé qua xem code và cho góp ý để hoàn thiện và học tập thêm kiến thức và kinh nghiệm.
Trân trọng.
 

File đính kèm

  • KLTH(cua VoVa2209).xlsm
    80.9 KB · Đọc: 7
Upvote 0
HUONGHCKT đã viết:
Bạn thử code cùi bắp này xem sao.
Mã: 
Sub XYZ()
Dim i&, j&, Lr&, R&, k&, t&, Z&
Dim Arr(), KQ()

With Sheet1
Lr = .Cells(Rows.Count, 1).End(xlUp).Row
Arr = .Range("A2:c" & Lr).Value
End With

R = UBound(Arr)
ReDim KQ(1 To R, 1 To 9)
For i = 1 To UBound(Arr)
    If Left(Arr(i, 1), 2) = "Km" Then
        k = k + 1
        Z = k * 2 - 1
        KQ(Z, 1) = Arr(i, 1)
        KQ(Z, 2) = k '- 1
        KQ(Z + 1, 3) = Mid(Arr(i, 1), 5, Len(Arr(i, 1)) - 4)
    Else
        If Left(Trim(Arr(i, 1)), 2) = "Km" Or Left(Trim(Arr(i, 1)), 1) = "C" Or Left(Trim(Arr(i, 1)), 1) = "V" Then
            Else
            DK = Trim(Arr(i, 1))
            If DK = "§¾p nÒn" Then t = 4
            If DK = "§µo ®Êt c3" Then t = 5
            If DK = "§µo r·nh ®Êt c3" Then t = 6
            If DK = "§µo khu«n ®Êt c3" Then t = 7
            If DK = "B mÆt ®êng" Then t = 8
            If DK = "L chiÕm dông" Then t = 9
               KQ(Z + 1, t) = Arr(i, 3)
        End If
    End If
Next i
Sheets("KLTH").[C4].Resize(k, 9) = KQ
End Sub
Tôi là luôn phần tổng hợp sang Sh KLTH. Hy vọng đúng ý.
Hãy thêm hoặc thay đổi dữ liệu và nhấn nút CHAY CODE ở Sh KLTH để xem và kiểm tra kết quả
Rất mong anh chị em trên diễn đàn ghé qua xem code và cho góp ý để hoàn thiện và học tập thêm kiến thức và kinh nghiệm.
Trân trọng.
Nhấp chuột vào đây để mở rộng...
Méo mó có hơn không? thế là quá rồi bạn ạ. để mình thử!
Bài đã được tự động gộp:

HUONGHCKT đã viết:
Bạn thử code cùi bắp này xem sao.
Mã: 
Sub XYZ()
Dim i&, j&, Lr&, R&, k&, t&, Z&
Dim Arr(), KQ()

With Sheet1
Lr = .Cells(Rows.Count, 1).End(xlUp).Row
Arr = .Range("A2:c" & Lr).Value
End With

R = UBound(Arr)
ReDim KQ(1 To R, 1 To 9)
For i = 1 To UBound(Arr)
    If Left(Arr(i, 1), 2) = "Km" Then
        k = k + 1
        Z = k * 2 - 1
        KQ(Z, 1) = Arr(i, 1)
        KQ(Z, 2) = k '- 1
        KQ(Z + 1, 3) = Mid(Arr(i, 1), 5, Len(Arr(i, 1)) - 4)
    Else
        If Left(Trim(Arr(i, 1)), 2) = "Km" Or Left(Trim(Arr(i, 1)), 1) = "C" Or Left(Trim(Arr(i, 1)), 1) = "V" Then
            Else
            DK = Trim(Arr(i, 1))
            If DK = "§¾p nÒn" Then t = 4
            If DK = "§µo ®Êt c3" Then t = 5
            If DK = "§µo r·nh ®Êt c3" Then t = 6
            If DK = "§µo khu«n ®Êt c3" Then t = 7
            If DK = "B mÆt ®êng" Then t = 8
            If DK = "L chiÕm dông" Then t = 9
               KQ(Z + 1, t) = Arr(i, 3)
        End If
    End If
Next i
Sheets("KLTH").[C4].Resize(k, 9) = KQ
End Sub
Tôi là luôn phần tổng hợp sang Sh KLTH. Hy vọng đúng ý.
Hãy thêm hoặc thay đổi dữ liệu và nhấn nút CHAY CODE ở Sh KLTH để xem và kiểm tra kết quả
Rất mong anh chị em trên diễn đàn ghé qua xem code và cho góp ý để hoàn thiện và học tập thêm kiến thức và kinh nghiệm.
Trân trọng.
Nhấp chuột vào đây để mở rộng...
Chưa lấy được hết dữ liệu bạn ạ! mới lấy đến được cọc 35 là nó dừng.
Tên công việc trong code điều kiện để là F4, G4, H4.. được không bạn. vì sang file khác tên công việc lại thay đổi.
Bạn sửa lại hộ mình nhé!

Untitled.png
 
Lần chỉnh sửa cuối:
Upvote 0
vova2209 đã viết:
Méo mó có hơn không? thế là quá rồi bạn ạ. để mình thử!
Bài đã được tự động gộp:


Chưa lấy được hết dữ liệu bạn ạ! mới lấy đến được cọc 35 là nó dừng.
Tên công việc trong code điều kiện để là F4, G4, H4.. được không bạn. vì sang file khác tên công việc lại thay đổi.
Bạn sửa lại hộ mình nhé!

View attachment 265113
Nhấp chuột vào đây để mở rộng...
Tôi nhác kiểm tra kỹ.
1/ Do khi gán kết quả đã không chú ý thay chỉ số k ở dòng
Sheets("KLTH").[C4].Resize(k, 9) = KQ bằng dòng Sheets("KLTH").[C4].Resize(Z + 1, 9) = KQ
2/ Hoàn toàn có thể được:
Thay vì IF DK="...." then t=... thì nay ta thay bằng một vòng lặp
With Sheets("KLTH")
For q = 6 To 11
If DK = .Cells(2, q) Then t = q - 2
Next q
End With
và xóa bỏ các dòng If DK="...." then t=... đi

Hoặc bạn xóa code cũ đị và thay code sau vào modul1 nhé.
Mã: 
Sub XYZ()
Dim i&, j&, Lr&, R&, k&, t&, Z&
Dim Arr(), KQ()

With Sheet1
Lr = .Cells(Rows.Count, 1).End(xlUp).Row
Arr = .Range("A2:C" & Lr).Value
End With

R = UBound(Arr)
ReDim KQ(1 To R, 1 To 9)
For i = 1 To UBound(Arr)
    If Left(Trim(Arr(i, 1)), 2) = "Km" Then
        k = k + 1
        Z = k * 2 - 1
        KQ(Z, 1) = Arr(i, 1)
        KQ(Z, 2) = k '- 1
        KQ(Z + 1, 3) = Mid(Arr(i, 1), 5, Len(Arr(i, 1)) - 4)
    Else
        If Left(Trim(Arr(i, 1)), 2) = "Km" Or Left(Trim(Arr(i, 1)), 1) = "C" Or Left(Trim(Arr(i, 1)), 1) = "V" Then
            Else
            DK = Trim(Arr(i, 1))
            With Sheets("KLTH")
                For q = 6 To 11
                    If DK = .Cells(2, q) Then t = q - 2
                Next q
            End With
               KQ(Z + 1, t) = Arr(i, 3)
        End If
    End If
Next i
Sheets("KLTH").[C4].Resize(Z + 1, 9) = KQ
End Sub
 

File đính kèm

  • KLTH(cua VoVa2209).xlsm
    86.6 KB · Đọc: 5
Upvote 0
Bạn dùng Font chữ gì mà lỗi tùm lum vậy? không thể chuyển về chuẩn Unicode sao?
 
Upvote 0
vova2209 đã viết:
Chào anh chị!
Nhờ anh chị giúp đỡ em sử lý số liệu như hình dưới đây:
1. Trong sheet"Doan 2" Lấy tên công việc từ cột A thống kê ra cột H (đặt lần lượt alpha B)
)
2. Copy tên công việc ở Sheet"Doan 2" cột H paste sang sheet"THKL" đặt từ cột F2 đến G2, H2...
3. Copy tên cọc từ cột A ở Sheet"Doan 2" paste sang sheet"THKL" cột D4 đến D..
4. Copy số tách từ Km+9.97 cột A ở Sheet"Doan 2" paste sang sheet"THKL" cột E5 đến D..
5. Copy số ứng với công việc từ cột C ở Sheet"Doan 2" paste sang sheet"THKL". VD tìm được "Đào khuôn đất c3" 4.37 copy sang sheet"THTL" đặt vào cột i
Em xin cảm ơn!

View attachment 265098
Nhấp chuột vào đây để mở rộng...
Bắt buộc phải so le dữ liệu thế kia hả bạn
 
Upvote 0
Cá ngừ F1 đã viết:
Bạn dùng Font chữ gì mà lỗi tùm lum vậy? không thể chuyển về chuẩn Unicode sao?
Nhấp chuột vào đây để mở rộng...
Xuất từ phần mềm sang font chữ nó .vn anh ạ.
Bài đã được tự động gộp:

buiquangthuan đã viết:
Bắt buộc phải so le dữ liệu thế kia hả bạn
Nhấp chuột vào đây để mở rộng...
vâng! bảng tính khối lượng mẫu như thế bạn ạ
Bài đã được tự động gộp:

HUONGHCKT đã viết:
Tôi nhác kiểm tra kỹ.
1/ Do khi gán kết quả đã không chú ý thay chỉ số k ở dòng
Sheets("KLTH").[C4].Resize(k, 9) = KQ bằng dòng Sheets("KLTH").[C4].Resize(Z + 1, 9) = KQ
2/ Hoàn toàn có thể được:
Thay vì IF DK="...." then t=... thì nay ta thay bằng một vòng lặp
With Sheets("KLTH")
For q = 6 To 11
If DK = .Cells(2, q) Then t = q - 2
Next q
End With
và xóa bỏ các dòng If DK="...." then t=... đi

Hoặc bạn xóa code cũ đị và thay code sau vào modul1 nhé.
Mã: 
Sub XYZ()
Dim i&, j&, Lr&, R&, k&, t&, Z&
Dim Arr(), KQ()

With Sheet1
Lr = .Cells(Rows.Count, 1).End(xlUp).Row
Arr = .Range("A2:C" & Lr).Value
End With

R = UBound(Arr)
ReDim KQ(1 To R, 1 To 9)
For i = 1 To UBound(Arr)
    If Left(Trim(Arr(i, 1)), 2) = "Km" Then
        k = k + 1
        Z = k * 2 - 1
        KQ(Z, 1) = Arr(i, 1)
        KQ(Z, 2) = k '- 1
        KQ(Z + 1, 3) = Mid(Arr(i, 1), 5, Len(Arr(i, 1)) - 4)
    Else
        If Left(Trim(Arr(i, 1)), 2) = "Km" Or Left(Trim(Arr(i, 1)), 1) = "C" Or Left(Trim(Arr(i, 1)), 1) = "V" Then
            Else
            DK = Trim(Arr(i, 1))
            With Sheets("KLTH")
                For q = 6 To 11
                    If DK = .Cells(2, q) Then t = q - 2
                Next q
            End With
               KQ(Z + 1, t) = Arr(i, 3)
        End If
    End If
Next i
Sheets("KLTH").[C4].Resize(Z + 1, 9) = KQ
End Sub
Nhấp chuột vào đây để mở rộng...
Bạn chỉnh hộ mình! Dữ liệu cột D bỏ số đầu tiên và đẩy lên bắt đầu từ ô E5

Untitled.png
 

File đính kèm

  • KLTH(cua VoVa2209) (1).xlsm
    86.3 KB · Đọc: 5
Upvote 0
vova2209 đã viết:
Chào anh chị!
Nhờ anh chị giúp đỡ em sử lý số liệu như hình dưới đây:
1. Trong sheet"Doan 2" Lấy tên công việc từ cột A thống kê ra cột H (đặt lần lượt alpha B)
)
2. Copy tên công việc ở Sheet"Doan 2" cột H paste sang sheet"THKL" đặt từ cột F2 đến G2, H2...
3. Copy tên cọc từ cột A ở Sheet"Doan 2" paste sang sheet"THKL" cột D4 đến D..
4. Copy số tách từ Km+9.97 cột A ở Sheet"Doan 2" paste sang sheet"THKL" cột E5 đến D..
5. Copy số ứng với công việc từ cột C ở Sheet"Doan 2" paste sang sheet"THKL". VD tìm được "Đào khuôn đất c3" 4.37 copy sang sheet"THTL" đặt vào cột i
Em xin cảm ơn
Nhấp chuột vào đây để mở rộng...
Thử 1 cách khác
Mã: 
Sub ABC()
    Dim Dic As Object, sArr(), Res(), i&, iR&, CViec(), KM, Culi, K&, x&, TenCoc
    Dim j&
    Set Dic = CreateObject("Scripting.dictionary")
    With Sheet1
        iR = .Range("A" & Rows.Count).End(3).Row
        sArr = .Range("A2:D" & iR).Value
        CViec = .Range("H2", .Range("H2").End(4)).Value
    End With
    For i = 1 To UBound(CViec, 1)
        If Dic.exists(CViec(i, 1)) = False Then Dic.Item(CViec(i, 1)) = i
    Next
    ReDim Res(1 To UBound(sArr, 1), 1 To 9)
    For i = 1 To UBound(sArr, 1)
        If sArr(i, 1) Like "Cäc:*" Then
            K = K + 1: x = K * 2 - 1
            TenCoc = Split(sArr(i, 1), ":")(1)
        End If
        If sArr(i, 1) Like "Km:*" Then
            KM = sArr(i, 1)
            Culi = Split(sArr(i, 1), "+")(1)
        End If
        Res(x, 1) = KM: Res(x, 2) = TenCoc: Res(x, 3) = Culi
        j = Dic.Item(sArr(i, 1))
        If j > 0 Then
            Res(x + 1, j + 3) = sArr(i, 3)
        End If
    Next
    Sheets("KLTH").Range("C4").Resize(10000, 9).ClearContents
    Sheets("KLTH").Range("C4").Resize(x+1, 9).Value = Res
End Sub
 
Lần chỉnh sửa cuối:
Upvote 0
buiquangthuan đã viết:
Thử 1 cách khác
Mã: 
Sub ABC()
    Dim Dic As Object, sArr(), Res(), i&, iR&, CViec(), KM, Culi, K&, x&, TenCoc
    Dim j&
    Set Dic = CreateObject("Scripting.dictionary")
    With Sheet1
        iR = .Range("A" & Rows.Count).End(3).Row
        sArr = .Range("A2:D" & iR).Value
    End With
    CViec = Sheets("KLTH").Range("F2:K2").Value
    For i = 1 To UBound(CViec, 2)
        If Dic.exists(CViec(1, i)) = False Then
            Dic.Item(CViec(1, i)) = i
        End If
    Next
    ReDim Res(1 To UBound(sArr, 1), 1 To 9)
    For i = 1 To UBound(sArr, 1)
        If sArr(i, 1) Like "Cäc:*" Then
            K = K + 1: x = K * 2 - 1
            TenCoc = Split(sArr(i, 1), ":")(1)
        End If
        If sArr(i, 1) Like "Km:*" Then
            KM = sArr(i, 1)
            Culi = Split(sArr(i, 1), "+")(1)
        End If
        Res(x, 1) = KM: Res(x, 2) = TenCoc: Res(x, 3) = Culi
        j = Dic.Item(sArr(i, 1))
        If j > 0 Then
            Res(x + 1, j + 3) = sArr(i, 3)
        End If
    Next
    Sheets("KLTH").Range("C4").Resize(10000, 9).ClearContents
    Sheets("KLTH").Range("C4").Resize(UBound(sArr, 1), 9).Value = Res
End Sub
Nhấp chuột vào đây để mở rộng...
Vâng! cảm ơn nhiều.. để mình chạy thử
Bài đã được tự động gộp:

buiquangthuan đã viết:
Có lý do gì mà lại đẩy lên như thế không bạn
Nhấp chuột vào đây để mở rộng...
9.97 là khoảng cách giữa 2 điểm
Nó nằm ở giữa điểm 1 và điểm 2 để thế nhìn cho trực quan bạn ạ.
Bài đã được tự động gộp:

buiquangthuan đã viết:
Thử 1 cách khác
Mã: 
Sub ABC()
    Dim Dic As Object, sArr(), Res(), i&, iR&, CViec(), KM, Culi, K&, x&, TenCoc
    Dim j&
    Set Dic = CreateObject("Scripting.dictionary")
    With Sheet1
        iR = .Range("A" & Rows.Count).End(3).Row
        sArr = .Range("A2:D" & iR).Value
        CViec = .Range("H2", .Range("H2").End(4)).Value
    End With
    For i = 1 To UBound(CViec, 1)
        If Dic.exists(CViec(i, 1)) = False Then Dic.Item(CViec(i, 1)) = i
    Next
    ReDim Res(1 To UBound(sArr, 1), 1 To 9)
    For i = 1 To UBound(sArr, 1)
        If sArr(i, 1) Like "Cäc:*" Then
            K = K + 1: x = K * 2 - 1
            TenCoc = Split(sArr(i, 1), ":")(1)
        End If
        If sArr(i, 1) Like "Km:*" Then
            KM = sArr(i, 1)
            Culi = Split(sArr(i, 1), "+")(1)
        End If
        Res(x, 1) = KM: Res(x, 2) = TenCoc: Res(x, 3) = Culi
        j = Dic.Item(sArr(i, 1))
        If j > 0 Then
            Res(x + 1, j + 3) = sArr(i, 3)
        End If
    Next
    Sheets("KLTH").Range("C4").Resize(10000, 9).ClearContents
    Sheets("KLTH").Range("C4").Resize(x+1, 9).Value = Res
End Sub
Nhấp chuột vào đây để mở rộng...
Tiêu đề Lý Trình chỉ tìm kiếm từ Km0+9.97 và đặt từ ô D5 bạn ạ. bạn chỉnh lại dùm mình chút
Đẩy dữ liệu lên 1 dòng bạn ạ, sửa chỗ nào nhỉUntitled.png
 
Lần chỉnh sửa cuối:
Upvote 0
vova2209 đã viết:
Tiêu đề Lý Trình chỉ tìm kiếm từ Km0+9.97 và đặt từ ô D5 bạn ạ. bạn chỉnh lại dùm mình chút
Đẩy dữ liệu lên 1 dòng bạn ạ, sửa chỗ nào nhỉ
Nhấp chuột vào đây để mở rộng...
Chỉnh lại code . Kết quả bạn tự test lấy
Mã: 
Sub ABC()
    Dim Dic As Object, sArr(), Res(), i&, iR&, CViec(), KM, Culi, K&, x&, TenCoc
    Dim j&
Set Dic = CreateObject("Scripting.dictionary")
With Sheet1
    iR = .Range("A" & Rows.Count).End(3).Row
    sArr = .Range("A2:D" & iR).Value
    CViec = .Range("H2", .Range("H2").End(4)).Value
End With
For i = 1 To UBound(CViec, 1)
    If Dic.exists(CViec(i, 1)) = False Then Dic.Item(CViec(i, 1)) = i
Next
ReDim Res(1 To UBound(sArr, 1), 1 To 9)
For i = 1 To UBound(sArr, 1)
    If sArr(i, 1) Like "Cäc:*" Then
        K = K + 1: x = K * 2 - 1
        TenCoc = Split(sArr(i, 1), ":")(1)
    End If
    If sArr(i, 1) Like "Km:*" Then
        KM = sArr(i, 1)
        Culi = Split(sArr(i, 1), "+")(1)
    End If
    Res(x, 1) = KM: Res(x, 2) = TenCoc
    If K > 1 Then Res(x - 1, 3) = Culi
    j = Dic.Item(sArr(i, 1))
    If j > 0 Then
        Res(x, j + 3) = sArr(i, 3)
    End If
Next
Sheets("KLTH").Range("C4").Resize(10000, 9).ClearContents
Sheets("KLTH").Range("C4").Resize(x + 1, 9).Value = Res
End Sub
 
Upvote 0
buiquangthuan đã viết:
Thử 1 cách khác
Mã: 
Sub ABC()
    Dim Dic As Object, sArr(), Res(), i&, iR&, CViec(), KM, Culi, K&, x&, TenCoc
    Dim j&
    Set Dic = CreateObject("Scripting.dictionary")
    With Sheet1
        iR = .Range("A" & Rows.Count).End(3).Row
        sArr = .Range("A2:D" & iR).Value
        CViec = .Range("H2", .Range("H2").End(4)).Value
    End With
    For i = 1 To UBound(CViec, 1)
        If Dic.exists(CViec(i, 1)) = False Then Dic.Item(CViec(i, 1)) = i
    Next
    ReDim Res(1 To UBound(sArr, 1), 1 To 9)
    For i = 1 To UBound(sArr, 1)
        If sArr(i, 1) Like "Cäc:*" Then
            K = K + 1: x = K * 2 - 1
            TenCoc = Split(sArr(i, 1), ":")(1)
        End If
        If sArr(i, 1) Like "Km:*" Then
            KM = sArr(i, 1)
            Culi = Split(sArr(i, 1), "+")(1)
        End If
        Res(x, 1) = KM: Res(x, 2) = TenCoc: Res(x, 3) = Culi
        j = Dic.Item(sArr(i, 1))
        If j > 0 Then
            Res(x + 1, j + 3) = sArr(i, 3)
        End If
    Next
    Sheets("KLTH").Range("C4").Resize(10000, 9).ClearContents
    Sheets("KLTH").Range("C4").Resize(x+1, 9).Value = Res
End Sub
Nhấp chuột vào đây để mở rộng...
Kết quả mong muốn như này bạn à!Untitled.png
 
Upvote 0
vova2209 đã viết:
Minh không có ý thay đổi liên tục. kết quả mong muốn trả về như hình bài #1 bạn à. Phiền bạn chỉnh 1 lần nữa..
Nhấp chuột vào đây để mở rộng...
Mình đã comment ở bài #13 rồi đó. code ở bài #11 là kết quả sau khi bạn muốn rồi đó
Bài đã được tự động gộp:

vova2209 đã viết:
Minh không có ý thay đổi liên tục. kết quả mong muốn trả về như hình bài #1 bạn à. Phiền bạn chỉnh 1 lần nữa..
Nhấp chuột vào đây để mở rộng...
code đã sửa:
Mã: 
Sub ABC()
    Dim Dic As Object, sArr(), Res(), i&, iR&, CViec(), KM, Culi, K&, x&, TenCoc
    Dim j&
Set Dic = CreateObject("Scripting.dictionary")
With Sheet1
    iR = .Range("A" & Rows.Count).End(3).Row
    sArr = .Range("A2:D" & iR).Value
    CViec = .Range("H2", .Range("H2").End(4)).Value
End With
For i = 1 To UBound(CViec, 1)
    If Dic.exists(CViec(i, 1)) = False Then Dic.Item(CViec(i, 1)) = i
Next
ReDim Res(1 To UBound(sArr, 1), 1 To 9)
For i = 1 To UBound(sArr, 1)
    If sArr(i, 1) Like "Cäc:*" Then
        K = K + 1: x = K * 2 - 1
        TenCoc = Split(sArr(i, 1), ":")(1)
    End If
    If sArr(i, 1) Like "Km:*" Then
        KM = sArr(i, 1): Culi = Split(sArr(i, 1), "+")(1)
    End If
    Res(x, 1) = KM: Res(x, 2) = TenCoc
    If K > 1 Then Res(x - 1, 3) = Culi
    j = Dic.Item(sArr(i, 1))
    If j > 0 Then
        Res(x, j + 3) = sArr(i, 3)
    End If
Next
Sheets("KLTH").Range("C4").Resize(10000, 9).ClearContents
Sheets("KLTH").Range("C4").Resize(x + 1, 9).Value = Res
End Sub
 
Lần chỉnh sửa cuối:
Upvote 0
buiquangthuan đã viết:
Mình đã comment ở bài #13 rồi đó. code ở bài #11 là kết quả sau khi bạn muốn rồi đó
Bài đã được tự động gộp:


code đã sửa:
Mã: 
Sub ABC()
    Dim Dic As Object, sArr(), Res(), i&, iR&, CViec(), KM, Culi, K&, x&, TenCoc
    Dim j&
Set Dic = CreateObject("Scripting.dictionary")
With Sheet1
    iR = .Range("A" & Rows.Count).End(3).Row
    sArr = .Range("A2:D" & iR).Value
    CViec = .Range("H2", .Range("H2").End(4)).Value
End With
For i = 1 To UBound(CViec, 1)
    If Dic.exists(CViec(i, 1)) = False Then Dic.Item(CViec(i, 1)) = i
Next
ReDim Res(1 To UBound(sArr, 1), 1 To 9)
For i = 1 To UBound(sArr, 1)
    If sArr(i, 1) Like "Cäc:*" Then
        K = K + 1: x = K * 2 - 1
        TenCoc = Split(sArr(i, 1), ":")(1)
    End If
    If sArr(i, 1) Like "Km:*" Then
        KM = sArr(i, 1): Culi = Split(sArr(i, 1), "+")(1)
    End If
    Res(x, 1) = KM: Res(x, 2) = TenCoc
    If K > 1 Then Res(x - 1, 3) = Culi
    j = Dic.Item(sArr(i, 1))
    If j > 0 Then
        Res(x, j + 3) = sArr(i, 3)
    End If
Next
Sheets("KLTH").Range("C4").Resize(10000, 9).ClearContents
Sheets("KLTH").Range("C4").Resize(x + 1, 9).Value = Res
End Sub
Nhấp chuột vào đây để mở rộng...
Code chạy đúng theo nguyện vọng rồi! cảm ơn bạn nhiều.. chúc bạn 1 ngày vui vẻ!
 
Upvote 0
vova2209 đã viết:
Xuất từ phần mềm sang font chữ nó .vn anh ạ.
Bài đã được tự động gộp:


vâng! bảng tính khối lượng mẫu như thế bạn ạ
Bài đã được tự động gộp:


Bạn chỉnh hộ mình! Dữ liệu cột D bỏ số đầu tiên và đẩy lên bắt đầu từ ô E5

View attachment 265123
Nhấp chuột vào đây để mở rộng...
Bạn xem lại file đính kèm.
Nhìn chung thì không hợp lý cho lắm. Tại sao không để trên một dòng mà lại phải chia ra so le thế. Vừa tiết kiệm được dung lượng vừa dễ xem dễ kiểm tra, sau này có nhu cầu tổng hợp sang Sh Tổng cũng dễ hơn nhiều.
 

File đính kèm

  • KLTH(cua VoVa2209) (1).xlsm
    90 KB · Đọc: 12
Upvote 0
HUONGHCKT đã viết:
Bạn xem lại file đính kèm.
Nhìn chung thì không hợp lý cho lắm. Tại sao không để trên một dòng mà lại phải chia ra so le thế. Vừa tiết kiệm được dung lượng vừa dễ xem dễ kiểm tra, sau này có nhu cầu tổng hợp sang Sh Tổng cũng dễ hơn nhiều.
Nhấp chuột vào đây để mở rộng...
Mẫu biểu trên mình họ bắt để như thế. mà nhìn cũng quen rồi. cảm ơn bạn nhiều!
 
Upvote 0
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

Tuấn Bụng Bự
  • Question
Tìm Bộ 8 số xuất hiện nhiều nhất trong random( 1 - 80)
Trả lời
13
Đọc
257
Tuấn Bụng Bự
Tuấn Bụng Bự
ongke0711
  • Question
Tải hóa đơn điện tử (https://hoadondientu.gdt.gov.vn/) Excel Vba
    • Thích
    • Yêu thích
11 12 13
Trả lời
245
Đọc
13K
Hoàng Trọng Hữu
Hoàng Trọng Hữu
H
Hàm đếm số ngày thứ bảy và chủ nhật trong một khoảng thời gian
Trả lời
17
Đọc
19K
Nhattanktnn
Nhattanktnn
D
  • Question
Xin cách sắp xếp dữ liệu theo thứ tự không làm hỏng link
Trả lời
7
Đọc
276
cantl
C
N
Giúp sửa mã code
Trả lời
16
Đọc
244
ptm0412
ptm0412
dung09031989
Xin giúp công thức tô màu các ô phía sau khi kế hoạch đặt hàng thiếu so với tồn kho.?
Trả lời
0
Đọc
34
dung09031989
dung09031989
V
[Nhờ giúp đỡ] Cách tìm thời gian bị trùng trong excel ở nhiều thời gian khác nhau
Trả lời
1
Đọc
40
tranvansau278
T
C
Công thức tự nhập liệu số lượng nhập khi bị âm
Trả lời
0
Đọc
36
cherry0187
C
N
Vẽ biểu đồ kết hợp nhiều yếu tố trong excel
Trả lời
1
Đọc
33
hoangminhtien
hoangminhtien
GPE-Trợ Lý
KHÓA HỌC BỨT PHÁ KỸ NĂNG EXCEL
    • Thích
Trả lời
0
Đọc
144
GPE-Trợ Lý
GPE-Trợ Lý
P
Tổng hợp dữ liệu từ các sheet theo chọn lọc
Trả lời
2
Đọc
74
phutdm
P
dunghtgiga
  • Đã khóa
Tính bốn tuần cho một tháng
Trả lời
9
Đọc
265
ptm0412
ptm0412
zarra
Cần giúp tạo form in mã vạch cho vật tư theo SL cụ thể.
Trả lời
3
Đọc
101
HUONGHCKT
H
Mr Đạo
in giấy ra bị lệch xuống dưới
    • Thích
2
Trả lời
29
Đọc
26K
Hoàng Tuấn 868
H
H
Không xem được ảnh trên Excel
Trả lời
3
Đọc
1K
huyentran9292
H
T
Xin form quản lý dữ liệu học viên của Trung tâm Đào tạo
Trả lời
2
Đọc
217
hakiru188
H
C
Code Lọc Dữ Liệu
Trả lời
10
Đọc
175
Cúc Hr
C
Y
Cách ẩn công thức 1 ô trong sheet
Trả lời
8
Đọc
119
hoangminhtien
hoangminhtien
vuha
  • Question
Lỗi chọn dòng thứ 6 trong sheet được chọn: rows("6:6").select
Trả lời
12
Đọc
160
ptm0412
ptm0412
Nguyencaocuong86
Tô màu dữ liệu trùng lặp trong excel.
Trả lời
10
Đọc
144
Nguyencaocuong86
Nguyencaocuong86
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

Back
Top Bottom