EXCEL VBA 二维表转换成一维表

曾经终败给现在 2022-03-20 16:10 539阅读 0赞

EXCEL VBA  二维表转换成一维表

Sub 按钮2_Click()
    
        Rem 初始化
        
        Worksheets(1).Activate
        Dim sizeArr(5)
        sizeArr(0) = "XS"
        sizeArr(1) = "S"
        sizeArr(2) = "M"
        sizeArr(3) = "L"
        sizeArr(4) = "XL"
        
        
        Dim col, row, productNum, refCol, targetRow
        
        targetRow = 1
        
        Sheet2.Range("A1:A65536").Clear
        
        Dim iA As Integer
        
        
        Rem 交叉表转一维表
        For row = 3 To 65536: Rem 处理行
        
            If StrComp(Sheet1.Cells(row, 1), "") = 0 Then GoTo line: Rem 如果为空就中止处理
            
            iA = Asc(Left(Sheet1.Cells(row, 1), 1))
            Rem 如果不是英文字符开头,就跳过
            If (iA >= 65 And iA <= 90) Or (iA >= 97 And iA <= 122) Then
            
                For col = 3 To 7: Rem 处理列
                    productNum = Sheet1.Cells(row, 1) & Left(Sheet1.Cells(row, 2), 2)
                           
                    Rem 取尺码对照表列号
                    If StrComp(Left(productNum, 1), "K") = 0 Then
                        refCol = 4
                    ElseIf StrComp(Left(productNum, 1), "B") = 0 Then
                        refCol = 3
                    ElseIf StrComp(Left(productNum, 1), "C") = 0 Then
                        refCol = 3
                    Else
                        refCol = 2
                    End If
                   
                    productNum = productNum & Sheet3.Cells(col - 1, refCol)
                    
                    Rem 取铺货件数，如果<=0，就跳过，否则插入一维表
                    If Sheet1.Cells(row, col) > 0 Then
                        Sheet2.Cells(targetRow, 1) = productNum & "," & Sheet1.Cells(row, col)
                        targetRow = targetRow + 1
                    End If
                    
                Next
             End If
    line:
        Next
        If targetRow = 1 Then
            Worksheets(1).Activate
            MsgBox "二维表没有数据！"
        Else
            Sheet2.Range("D4").Value = targetRow - 1
            Worksheets(2).Activate
            MsgBox "生成成功！"
        End If
        
    End Sub