vba 列转行

最新推荐文章于 2024-05-26 15:29:39 发布

weixin_34150503

最新推荐文章于 2024-05-26 15:29:39 发布

阅读量535

点赞数

本文介绍了一段使用VBA实现的数据迁移与处理脚本，该脚本从一个工作表中读取特定区域的数据，并根据条件将其复制到另一个工作表中，同时标记已删除的数据项。此过程涉及对字符串的操作、条件判断以及数据表格的更新。

摘要生成于 C知道，由 DeepSeek-R1 满血版支持，前往体验 >



Sub C2R()
    
    Dim RCount As Integer
    RCount = 2
    
    Dim FillIn, FillIn2
    Set FillIn = Worksheets("Fill-in Forms")
    Set FillIn2 = Worksheets("fillinforms2")
    
    
    Application.ScreenUpdating = False
    
    Dim ENCommentIndex%, OptionalForm%
    Dim OptionalList$
    OptionalList = "CA0106, CA0121, CA0121, CA0199, CA0240, CA0240, CA0305, CA0409, CA0410, CA0444, CA0444, CA2010, CA2010, CA2011, CA2033, CA2033, CA2048, CA2048, CA2054, CA2054, CA2055, CA2055, CA2067, CA2071, CA2071, CA2502, CA9910, CA9910, CA9916, CA9933, CA9933,"
    
    
    For Each EN In FillIn.Range("B2:DG2")
        
        ENCommentIndex = InStr(FillIn.Cells(2, EN.Column + 1).Value, EN.Value)
        OptionalForm = InStr(OptionalList, EN.Value)
        
        If InStr(EN.Value, "Comm") = 0 Then
            For Each Fill In FillIn.Range("A3:A166")
                If Cells(Fill.Row, EN.Column).Value <> "" Then
                    EN.Copy (FillIn2.Range("A" & RCount)) 'en name
                    Fill.Copy (FillIn2.Range("B" & RCount)) 'field desc
                    Cells(Fill.Row, EN.Column).Copy (FillIn2.Range("C" & RCount)) 'X
                    
                    If ENCommentIndex > 0 Then
                        Cells(Fill.Row, EN.Column + 1).Copy (FillIn2.Range("D" & RCount)) 'comment
                    End If
                    
                    If OptionalForm = 0 Then
                        FillIn2.Range("E" & RCount) = "Conditional"
                    Else
                        FillIn2.Range("E" & RCount) = "Optional"
                    End If
                   
                    RCount = RCount + 1
                    
                End If
                
            Next
        End If
        
    Next
    
End Sub


Sub RemoveDeletedEN()

    Dim red_en$
    red_en = "CA2018, CA2018, CA2021, CA2021, CA2027, CA2027, CA2030, CA2030, CA2071, CA2071, CA9923, CA9923, CA9930, CA9930, CA9960, CA9960, CA2016, CA2016, CA2017, CA2017,"
    
    Dim fillinforms2
    Set fillinforms2 = Worksheets("fillinforms2")
    
    For Each EN In fillinforms2.Range("A2:A300")
        
        If EN.Value <> "" And InStr(red_en, EN.Value) <> 0 Then
            fillinforms2.Range("F" & EN.Row) = "deleted"
        End If
    
    Next
    
End Sub