zoukankan      html  css  js  c++  java
  • 数据格式转置

    方案一:数据少时省事
    
    Private Sub CustomTransform1()
    
        Dim Wb As Workbook, Sht As Worksheet
    
        Dim NewSht As Worksheet, Dic As Object
    
        Dim EndRow As Long, iRow
    
        
    
        Set Dic = CreateObject("Scripting.Dictionary")
    
        Set Wb = Application.ThisWorkbook
    
        Set Sht = Wb.Worksheets("原始数据")
    
        
    
        '新建一张工作表,若之前已经存在同名工作表,直接删除
    
        Set NewSht = Wb.Worksheets.Add(After:=Wb.Worksheets(Wb.Worksheets.Count))
    
        Application.DisplayAlerts = False '关闭警告提示
    
        On Error Resume Next
    
        Wb.Worksheets("转置结果").Delete
    
        On Error GoTo 0
    
        Application.DisplayAlerts = True '重新打开警告提示
    
        NewSht.Name = "转置结果"
    
        NewSht.Cells.ClearContents
    
        
    
        With Sht
    
            EndRow = .Cells(.Cells.Rows.Count, 1).End(xlUp).Row
    
            For i = 1 To EndRow
    
                Key = .Cells(i, 1).Value
    
                
    
                '当A列的某个信息第一次出现时,为它编排一个序号,同时作为转置后的行号
    
                If Dic.Exists(Key) = False Then
    
                    Dic(Key) = Dic.Count + 1
    
                End If
    
    
    
                iRow = Dic(Key) '输出的行号
    
                
    
                NewSht.Cells(iRow, "A").Value = Key
    
                NewSht.Cells(iRow, "IV").End(xlToLeft).Offset(0, 1).Value = .Cells(i, 2).Value
    
            Next i
    
        End With
    
        '释放对象
    
        Set Dic = Nothing: Set Wb = Nothing
    
        Set Sht = Nothing: Set NewSht = Nothing
    
    End Sub
    
    
    
    
    
    方案二:数据多时效率相对高点
    
    Private Sub CustomTransform2()
    
        Dim Wb As Workbook, Sht As Worksheet
    
        Dim NewSht As Worksheet, Dic As Object
    
        Dim Arr(), Ar As Variant
    
        Dim EndRow As Long, EndCol As Long
    
        Set Dic = CreateObject("Scripting.Dictionary")
    
        Set Wb = Application.ThisWorkbook
    
        Set Sht = Wb.Worksheets("原始数据")
    
        '新建一张工作表,若之前已经存在同名工作表,直接删除
    
        Set NewSht = Wb.Worksheets.Add(After:=Wb.Worksheets(Wb.Worksheets.Count))
    
        Application.DisplayAlerts = False '关闭警告提示
    
        On Error Resume Next
    
        Wb.Worksheets("转置结果").Delete
    
        On Error GoTo 0
    
        Application.DisplayAlerts = True '重新打开警告提示
    
        NewSht.Name = "转置结果"
    
        NewSht.Cells.ClearContents
    
        
    
        With Sht
    
            EndRow = .Cells(.Cells.Rows.Count, 1).End(xlUp).Row
    
            Set Rng = .Range("A1:B" & EndRow)
    
            Ar = Rng.Value
    
            r = 0
    
            
    
            ReDim Arr(1 To EndRow, 1 To 20) '构造二维数组
    
            For i = LBound(Ar) To UBound(Ar)
    
                Key = CStr(Ar(i, 1))
    
                If Dic.Exists(Key) = False Then
    
                    Dic(Key) = 1
    
                Else
    
                    Dic(Key) = Dic(Key) + 1
    
                End If
    
                r = Dic.Count: c = Dic(Key)
    
                Arr(r, 1) = r: Arr(r, c + 1) = Ar(i, 2)
    
            Next i
    
        End With
    
        '快速输出结果
    
        NewSht.Range("A1").Resize(UBound(Arr), UBound(Arr, 2)).Value = Arr
    
        '释放对象
    
        Set Dic = Nothing: Set Wb = Nothing
    
        Set Sht = Nothing: Set NewSht = Nothing
    
    End Sub
    

      

  • 相关阅读:
    vsftpd匿名用户实验
    CentOS7 突然连不上网,报错"FailedtostartLSB:Bring up/down networking"
    搭建Java Web开发环境
    Starting named:[FAILED] named启动失败
    CentOS6克隆虚拟机报错Device eth0 does not seem to be present,delaying initialization.
    ADD requires at least two arguments
    mysql 5.7密码策略修改
    JavaScript手册
    vs编译生成之后报错
    vs编译生成之后报错
  • 原文地址:https://www.cnblogs.com/nextseven/p/9746896.html
Copyright © 2011-2022 走看看