输出的结果在A，B，C栏， 如何改成输出的结果在A，B，H栏

dogfire4169

With Sheet3.Range("A1").Resize(drCount, 3)

        .CurrentRegion.ClearContents
        .NumberFormatLocal = "@"
        .Value = Data
    End With


这时code 的.value=data 输出的结果在A，B，C栏， 如何改成输出的结果在A，B，H栏？？？
我知道输出后offset，C 栏就好，但是还是想学习一下，data array 的结构如图。
多谢了！！

杨建营

把数组的列扩大到H列

zjzyj

[h1].resize(drcount,1)=Application.Index(data, , 3)

洋务德雷

1. Sheet3.Range("h1").Resize(drCount, 1)=application.index(arr,0,3)

复制代码

shiruiqiang

With Sheet3.Range("A1").Resize(drCount, 8)

3190496160

上传附件和完整的代码才可能帮到你的

dogfire4169

补上code

Sub TransformData()
   
    Const SRC_FIRST_CELL As String = "A1"
    Const DST_FIRST_CELL As String = "I1"
    Const DATE_COL As Long = 1
    Const HOUR_COL As Long = 2
    Const WIND_COL As Long = 3
    Const DH_DELIMITER As String = "|!|"
    Const WIND_DELIMITER As String = "/"
    Const COLUMNS_COUNT As Long = 3 ' fixed
   
    Dim ws As Worksheet: Set ws = ActiveSheet ' improve!
   
    Dim srg As Range: Set srg = ws.Range(SRC_FIRST_CELL).CurrentRegion
    Dim srCount As Long: srCount = srg.Rows.Count
   
    Dim dData(): dData = srg.Columns(DATE_COL).Value
    Dim hData(): hData = srg.Columns(HOUR_COL).Value
    Dim wData(): wData = srg.Columns(WIND_COL).Value
   
    Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
    dict.CompareMode = vbTextCompare
   
    Dim r As Long, dString As String, wString As String
   
    For r = 2 To srCount
        dString = dData(r, 1) & DH_DELIMITER & hData(r, 1)
        If Not dict.Exists(dString) Then
            Set dict(dString) = CreateObject("Scripting.Dictionary")
        End If
        wString = wData(r, 1)
        dict(dString)(wString) = dict(dString)(wString) + 1
    Next r
   
    Dim drCount As Long: drCount = dict.Count + 1
   
    Dim Data(): ReDim Data(1 To drCount, 1 To COLUMNS_COUNT)
    Dim dLen As Long: dLen = Len(DH_DELIMITER)
   
    Data(1, 1) = dData(1, 1)
    Data(1, 2) = hData(1, 1)
    Data(1, 3) = wData(1, 1)
    r = 1
    wString = ""
   
    Dim oKey, iKey, dPos As Long, wMax As Long
   
    For Each oKey In dict.Keys
        r = r + 1
        dPos = InStr(oKey, DH_DELIMITER) - 1
        Data(r, 1) = CDate(Left(oKey, dPos))
        Data(r, 2) = CLng(Right(oKey, Len(oKey) - dPos - dLen))
        For Each iKey In dict(oKey).Keys
            'Debug.Print r, oKey, iKey, dict(oKey)(iKey)
            If dict(oKey)(iKey) > wMax Then
                wString = iKey
                wMax = dict(oKey)(iKey)
            ElseIf dict(oKey)(iKey) = wMax Then
                wString = wString & WIND_DELIMITER & iKey
            End If
        Next iKey
        Data(r, 3) = wString
        'Debug.Print Data(r, 1), Data(r, 2), Data(r, 3)
        wMax = 0
        wString = ""
    Next oKey
   
    With ws.Range(DST_FIRST_CELL).Resize(drCount, COLUMNS_COUNT)
        .CurrentRegion.ClearContents
        .Value = Data
    End With
   
    MsgBox "Data transformed.", vbInformation

End Sub

micch

输出完复制粘贴一下

With Sheet3.Range("A1").Resize(drCount, 3)

        .CurrentRegion.ClearContents
        .NumberFormatLocal = "@"
        .Value = Data
    End With
Sheet3.Range("h1").Resize(drCount).value=Sheet3.Range("c1").Resize(drCount).value

dogfire4169

micch 发表于 2023-3-4 10:33
输出完复制粘贴一下

With Sheet3.Range("A1").Resize(drCount, 3)

这和copy paste 一样的。多谢了。 我已经自己搞定了