20170728xlVBA改转置一例

Sub 导出()
    
    Dim Sht As Worksheet, ShtName As String
    Dim NextRow As Long, NextRow2 As Long
    Dim iRow As Long, Index As Long
    Dim mySum As Double
    iRow = 2

    Sheets("地块表").Activate

    Do While Cells(iRow, "F").Value <> ""

        ShtName = Cells(iRow, "F").Value
        Set Sht = Sheets(ShtName)

        NextRow = Sht.Range("C65536").End(xlUp).Row + 1

        If NextRow = 3 Then
            mySum = 0
            Index = 0
        End If

        Index = Index + 1
        
        If Index <= 39 Then
            Sht.Cells(NextRow, "A").Value = Cells(iRow, "A").Value    '序号
            Sht.Cells(NextRow, "C").Value = Cells(iRow, "B").Value    '农户代表
            Sht.Cells(NextRow, "G").Value = Cells(iRow, "C").Value    '地块数
            Sht.Cells(NextRow, "K").Value = Cells(iRow, "D").Value    '承包面积
        Else
            NextRow2 = Sht.Range("O65536").End(xlUp).Row + 1
            Sht.Cells(NextRow2, "O").Value = Cells(iRow, "A").Value    '序号
            Sht.Cells(NextRow2, "Q").Value = Cells(iRow, "B").Value    '农户代表
            Sht.Cells(NextRow2, "U").Value = Cells(iRow, "C").Value    '地块数
            Sht.Cells(NextRow2, "Y").Value = Cells(iRow, "D").Value    '承包面积
        End If

        mySum = mySum + Cells(iRow, "D").Value    '累计承包面积
        Sht.Range("Q42").Value = mySum

        iRow = iRow + 1
        ShtName = Cells(iRow, "F").Value
    Loop

    MsgBox ("ok")
End Sub