Chuyển dữ liệu từ hàng ngang về hàng dọc

[597335]

Chúng tôi đấu thầu dự án, thời gian cho từ khi mua HSMT đến khi nộp là 15 ngày, trong khoảng thời gian này nhà thầu phải làm rất nhiều công việc cho quá trình chuẩn bị HSDT

Tuy nhiên, Chủ đầu tư chơi khó bắt buộc nhà thầu phải tổng hợp theo mẫu bảng do Chủ đầu tư ban hành, dữ liệu mà phần mềm Dự toán xuất ra như sau:

Nay chủ đầu tư yêu cầu phải tổng hợp theo mẫu

Do khối lượng xử lý khoảng 10.000 dòng, xin được Post mẫu một số công việc tiêu biểu.

Xin nhờ mọi người giúp cho.

 

[phan ngoc lan]

Về phần dự toán mình chẳng biết gì cả nhưng việc Chuyển dữ liệu từ hàng ngang về hàng dọc mình có làm thử bạn kiểm tra xem thế nào nhé!
P\S: nhấn Ctrl + Q để chạy nhé chúc bạn thành công!

 

[597335]

Chị Ngọc Lan siêu quá, xin chị giải thích hộ cách làm ý nghĩa của Function, tôi nhìn mà chẳng hiểu gì cả

Public Sub Vertical_horizontal()

    Dim MySheet As Worksheet
    Dim YourSheet As Worksheet
    Dim i As Long, j As Long, k As Long, csD As String

    Set MySheet = ThisWorkbook.Sheets("Don gia chi tiet")
    Set YourSheet = ThisWorkbook.Sheets("Sheet1")

    Application.ScreenUpdating = False

    If YourSheet.Range("A65536").End(xlUp).Row >= 4 Then
        YourSheet.Rows("4:" & YourSheet.Range("A65536").End(xlUp).Row).Borders.LineStyle = xlNone
    End If

    With MySheet
        i = 3:  j = 3

        Do While i <= .Range("H65536").End(xlUp).Row

            If .Cells(i, 1) <> vbNullString Then
                j = j + 1
                YourSheet.Cells(j, 1) = .Cells(i, 1)
                YourSheet.Cells(j, 2) = .Cells(i, 2)
                YourSheet.Cells(j, 3) = .Cells(i, 3)
                YourSheet.Cells(j, 4) = .Cells(i, 4)
                YourSheet.Cells(j, 16).FormulaR1C1 = "=RC[-1]+RC[-2]"
            Else

                csD = "='Don gia chi tiet'!" & .Cells(i, 8).Address

                If InStr(1, .Cells(i, 3), UNC(") VËt liÖu")) > 0 Then
                    YourSheet.Cells(j, 5) = csD
                    GoTo NextCell
                End If

                If InStr(1, .Cells(i, 3), UNC(") Nh©n c«ng")) > 0 Then
                    YourSheet.Cells(j, 6) = csD
                    GoTo NextCell
                End If

                If InStr(1, .Cells(i, 3), UNC(") M¸y thi c«ng")) > 0 Then
                    YourSheet.Cells(j, 7) = csD
                    GoTo NextCell
                End If

                Select Case .Cells(i, 4)

                    Case "TT": k = 8
                    Case "T": k = 9
                    Case "C": k = 10
                    Case "TL": k = 11
                    Case "G": k = 12
                    Case "GTGT": k = 13
                    Case "Gxdcpt": k = 14
                    Case "Gxdnt": k = 15
                    Case Else: GoTo NextCell
                End Select

                YourSheet.Cells(j, k) = csD

            End If

NextCell:
            i = i + 1
        Loop
    End With

    If YourSheet.Range("A65536").End(xlUp).Row >= 4 Then

        YourSheet.Range("A4:P" & YourSheet.Range("A65536").End(xlUp).Row).Borders.LineStyle = xlContinuous

    End If

    Application.ScreenUpdating = True

    Set MySheet = Nothing
    Set YourSheet = Nothing

End Sub

Function UNC(Text As String) As String

    Dim iUNI As Variant, iTCVN As Variant, SText As String
    Dim i As Long, j As Long, istr As String

    iUNI = Array(225, 224, 7843, 227, 7841, 226, 7845, 7847, 7849, 7851, 7853, 259, 7855, 7857, 7859, _
            7861, 7863, 273, 233, 232, 7867, 7869, 7865, 234, 7871, 7873, 7875, 7877, 7879, 237, 236, 7881, 297, _
            7883, 243, 242, 7887, 245, 7885, 244, 7889, 7891, 7893, 7895, 7897, 417, 7899, 7901, 7903, 7905, 7907, _
            250, 249, 7911, 361, 7909, 432, 7913, 7915, 7917, 7919, 7921, 253, 7923, 7927, 7929, 7925, 193, 192, 7842, _
            195, 7840, 194, 7844, 7846, 7848, 7850, 7852, 258, 7854, 7856, 7858, 7860, 7862, 272, 201, 200, 7866, 7868, _
            7864, 202, 7870, 7872, 7874, 7876, 7878, 205, 204, 7880, 296, 7882, 211, 210, 7886, 213, 7884, 212, 7888, _
            7890, 7892, 7894, 7896, 416, 7898, 7900, 7902, 7904, 7906, 218, 217, 7910, 360, 7908, 431, 7912, 7914, 7916, _
            7918, 7920, 221, 7922, 7926, 7928, 7924)
    iTCVN = Array("¸", "µ", "¶", "·", "¹", "©", "Ê", "Ç", "È", "É", "Ë", "¨", "¾", "»", "¼", "½", "Æ", "®", "Ð", _
            "Ì", "Î", "Ï", "Ñ", "ª", "Õ", "Ò", "Ó", "Ô", "Ö", "Ý", "×", "Ø", "Ü", "Þ", "ã", "ß", "á", "â", "ä", "«", "è", _
            "å", "æ", "ç", "é", "¬", "í", "ê", "ë", "ì", "î", "ó", "ï", "ñ", "ò", "ô", "­", "ø", "õ", "ö", "÷", "ù", "ý", _
            "ú", "û", "ü", "þ", "¸", "µ", "¶", "·", "¹", "¢", "Ê", "Ç", "È", "É", "Ë", "¡", "¾", "»", "¼", "½", "Æ", "§", _
            "Ð", "Ì", "Î", "Ï", "Ñ", "£", "Õ", "Ò", "Ó", "Ô", "Ö", "Ý", "×", "Ø", "Ü", "Þ", "ã", "ß", "á", "â", "ä", "¤", _
            "è", "å", "æ", "ç", "é", "¥", "í", "ê", "ë", "ì", "î", "ó", "ï", "ñ", "ò", "ô", "¦", "ø", "õ", "ö", "÷", "ù", _
            "ý", "ú", "û", "ü", "þ")
    SText = Text

    For i = 1 To Len(SText)
        istr = Mid(SText, i, 1)

        If AscW(istr) >= 161 And AscW(istr) <= 254 Then

            For j = 0 To UBound(iTCVN)

                If istr = iTCVN(j) Then istr = ChrW(iUNI(j)): Exit For

            Next

        End If

        UNC = UNC + istr
    Next

End Function

 

[phan ngoc lan]

Cảm ơn bạn đã khen nhưng mình chỉ biết chút xíu thôi mà trên diễn đàn còn nhiều người giỏi lắm bạn đừng khen mình như thế nữa nhé!
Tất cả chỉ sử dụng thủ tục: Public Sub Vertical_horizontal() thôi, còn hàm UNC chỉ để mình hiển thị Unicode

Public Sub Vertical_horizontal()

    Đây là khai báo các biến
    Dim MySheet As Worksheet
    Dim YourSheet As Worksheet
    Dim i As Long, j As Long, k As Long, csD As String

    Mình đặt sheet cần chuyển(MySheet) và sheet sẽ chuyển(YourSheet) cho dễ sử dụng 
    Set MySheet = ThisWorkbook.Sheets("Don gia chi tiet")
    Set YourSheet = ThisWorkbook.Sheets("Sheet1")

    Application.ScreenUpdating = False

    Ta xoá các dữ liệu cũ của sheet YourSheet
    Mình quên mất lúc đầu cho xoá toàn bộ sau sửa lại chỉ xoá Borders
    Vậy bạn thay dòng này:
    If YourSheet.Range("A65536").End(xlUp).Row >= 4 Then
        YourSheet.Rows("4:" & YourSheet.Range("A65536").End(xlUp).Row).Borders.LineStyle = xlNone
    End If

    bằng dòng:
    If YourSheet.Range("A65536").End(xlUp).Row >= 4 Then
        YourSheet.Rows("4:" & YourSheet.Range("A65536").End(xlUp).Row).ClearContents
        YourSheet.Rows("4:" & YourSheet.Range("A65536").End(xlUp).Row).Borders.LineStyle = xlNone
    End If

    With MySheet
       Đặt i là dòng mình đang xét trong sheet MySheet
       Đặt j là dòng mình đang xét trong sheet YourSheet
        i = 3:  j = 3
        Lặp từ dòng thứ 3 đến dòng cuối có giá trị của sheet MySheet
        Do While i <= .Range("H65536").End(xlUp).Row

            nếu ô Ai của sheet MySheet có giá trị thì:
            If .Cells(i, 1) <> vbNullString Then
            Ta xét tới công việc mới bên sheet YourSheet ta xuống dòng và điền các giá trị.
                j = j + 1
                YourSheet.Cells(j, 1) = .Cells(i, 1)
                YourSheet.Cells(j, 2) = .Cells(i, 2)
                YourSheet.Cells(j, 3) = .Cells(i, 3)
                YourSheet.Cells(j, 4) = .Cells(i, 4)
                YourSheet.Cells(j, 16).FormulaR1C1 = "=RC[-1]+RC[-2]"
            Else

            Còn không ta vẫn xét trong công việc trước 

                Lấy tham chiếu tới ô Hi trong sheet MySheet
                csD = "='Don gia chi tiet'!" & .Cells(i, 8).Address

                Tìm kiếm nếu thấy có từ: Vật liệu thì điền vào ô vật liệu bên sheet YourSheet
                If InStr(1, .Cells(i, 3), UNC(") VËt liÖu")) > 0 Then
                    YourSheet.Cells(j, 5) = csD
                    Tiếp tục dòng sau:
                    GoTo NextCell
                End If

                Tìm kiếm nếu thấy có từ: Nhân công thì điền vào ô Nhân công bên sheet YourSheet
                If InStr(1, .Cells(i, 3), UNC(") Nh©n c«ng")) > 0 Then
                    YourSheet.Cells(j, 6) = csD
                    Tiếp tục dòng sau:
                    GoTo NextCell
                End If

                Tìm kiếm nếu thấy có từ: Máy thi công thì điền vào ô Máy thi công bên sheet YourSheet
                If InStr(1, .Cells(i, 3), UNC(") M¸y thi c«ng")) > 0 Then
                    YourSheet.Cells(j, 7) = csD
                    Tiếp tục dòng sau:
                    GoTo NextCell
                End If

                Chọn các giá trị trong sheet MySheet nếu thỏa mãn ta chuyển sang sheet YourSheet
                Select Case .Cells(i, 4)
                    Case "TT": k = 8
                    Case "T": k = 9
                    Case "C": k = 10
                    Case "TL": k = 11
                    Case "G": k = 12
                    Case "GTGT": k = 13
                    Case "Gxdcpt": k = 14
                    Case "Gxdnt": k = 15
                    Case Else: GoTo NextCell
                End Select

                YourSheet.Cells(j, k) = csD

            End If

NextCell:
            i = i + 1
        Loop
    End With

    Đặt Borders cho các giá trị ta vừa tạo
    If YourSheet.Range("A65536").End(xlUp).Row >= 4 Then

        YourSheet.Range("A4:P" & YourSheet.Range("A65536").End(xlUp).Row).Borders.LineStyle = xlContinuous

    End If

    Application.ScreenUpdating = True

    giải phóng bộ nhớ
    Set MySheet = Nothing
    Set YourSheet = Nothing

End Sub