Excel VBA笔记2

来源：互联网发布：服装淘宝推广方案编辑：程序博客网时间：2024/05/16 05:30

Sub RowTransfer()
    Dim row As Long
    Dim col As Long

    Dim rangeStr As String
    Dim tempStr As String

    ' 目标Sheet页中的行标
    Dim i As Integer

    '源Sheet页与目标Sheet页
    Dim sourceSheet As String
    Dim destSheet As String

    ' 最大的行号,列号
    Dim maxRow As Integer
    Dim maxCol As Integer

    ' 目标表中的帐目编号、帐目名、帐目细项编号、帐目细项名的列号
    Dim acctIdCol As Integer
    Dim acctNameCol As Integer
    Dim acctItemIdCol As Integer
    Dim acctItemNameCol As Integer

    ' 目标表中的起始行号
    i = 2

    sourceSheet = "Sheet1"
    destSheet = "Sheet3"

    acctIdCol = 1
    acctNameCol = 2
    acctItemIdCol = 4
    acctItemNameCol = 3
    acctItemrateCol = 5

    '获取源Sheet最大行号
    maxRow = Worksheets(sourceSheet).Range("A65536").End(xlUp).row

    For row = 2 To maxRow

        '删除首单元格为空的行
        If Trim(Worksheets(sourceSheet).Cells(row, 1).Value) <> "" Then
            'Worksheets(sourceSheet).Cells(row, 1).EntireRow.Delete shift:=xlUp

            ' 获取该行最大列号
            rangeStr = "IV" & CStr(row)
            maxCol = Worksheets(sourceSheet).Range(rangeStr).End(xlToLeft).Column

            For col = 3 To maxCol Step 2

                '判断单元格是否为空, 若为空则退出循环
                If Trim(Worksheets(sourceSheet).Cells(row, col).Value) <> "" Then

                    '获取源Sheet行首的项目号, 放入目标Sheet的第1列
                    Worksheets(destSheet).Cells(i, acctIdCol).Value = _
                        Worksheets(sourceSheet).Cells(row, 1).Value

                    '获取源Sheet的项目名, 放入目标Sheet的第2列
                    Worksheets(destSheet).Cells(i, acctNameCol).Value = _
                        Worksheets(sourceSheet).Cells(row, 2).Value

                    tempStr = Worksheets(sourceSheet).Cells(row, col).Value

                    If InStr(tempStr, "*") > 0 Then

                        '获取帐目内容,放入第二列
                        Worksheets(destSheet).Cells(i, acctItemNameCol).Value = _
                            Left(tempStr, InStr(tempStr, "*") - 1)

                        '取分成比例,放入第四列
                        Worksheets(destSheet).Cells(i, acctItemrateCol).Value = _
                            Right(tempStr, Len(tempStr) - InStr(tempStr, "*"))
                    Else
                        Worksheets(destSheet).Cells(i, acctItemNameCol).Value = tempStr
                        Worksheets(destSheet).Cells(i, acctItemrateCol).Value = 1
                    End If


                    '获取帐目项编号, 放入第三列
                    Worksheets(destSheet).Cells(i, acctItemIdCol).Value = _
                        Worksheets(sourceSheet).Cells(row, col + 1).Value

                    '目标表游标下移一行
                    i = i + 1

                End If
            Next col
        End If
    Next row
End Sub