[已解决]麻烦grf1973 老师帮忙修改红色标识代码，谢谢！

love_liwu

跟[已解决]麻烦老师帮忙看看，如何才能实现？类似，不同的地方是： 疑问.zip (50.71 KB, 下载次数: 4)

2017-2-16 19:32 上传

点击文件名下载附件
http://www.excelpx.com/thread-427615-1-1.html
(出处: Excel精英培训网)


上一题目的《客户信息表》


现在的《客户信息表》：


效果图（还是一样）：

从以上截图可看出，问题是 《客户信息表》的顺序跟《顾客信息》的顺序不同，怎么修改以下代码。请老师指示：

Sub 生成客户信息表()
    Dim sh As Worksheet, wb As Workbook
    Set d = CreateObject("scripting.dictionary")
    arr = [a1].CurrentRegion
    For i = 2 To UBound(arr)
        d(arr(i, 2)) = d(arr(i, 2)) & "," & i
    Next
    Set wb = Workbooks.Open(ThisWorkbook.Path & "\顾客信息.xls")
    Set sh = wb.Worksheets(1)
    For Each x In d.keys
        sh.Activate
        sh.Copy
        xrr = Split(d(x), ",")
        With ActiveSheet
            .[c4] = arr(xrr(1), 1)
            .[c5] = arr(xrr(1), 2)
            .[c6] = arr(xrr(1), 3)
            ReDim brr(1 To UBound(xrr), 4 To UBound(arr, 2))
            For i = 1 To UBound(xrr)
                For j = 4 To UBound(arr, 2)
                    brr(i, j) = arr(xrr(i), j)
                Next
            Next
            .[b8].Resize(i - 1, j - 4) = brr
        End With
        ActiveWorkbook.Close True, ThisWorkbook.Path & "\顾客信息-" & x
    Next
    wb.Close
End Sub

最佳答案

月排行榜 / 总排行榜

shjarthur

2017-2-16 23:17

看了下，只是原表列的顺序发生了变化，这样改动最简单的方法就是在写入前直接对调顺序。
    ReDim brr(1 To UBound(xrr), 4 To UBound(arr, 2))
    For i = 1 To UBound(xrr)
        For j = 4 To UBound(arr, 2)
            brr(i, j) = arr(xrr(i), j)
        Next
    Next
    For i = 1 To UBound(brr)
        xx = brr(i, 4)
        brr(i, 4) = brr(i, 5)
        brr(i, 5) = xx
        xx = brr(i, 6)
        brr(i, 6) = brr(i, 7)
        brr(i, 7) = xx
    Next
    .[b8].Resize(i - 1, j - 4) = brr
在现有代码中插入以上红色部分即可。

跳转到最佳答案楼层

shjarthur

看了下，只是原表列的顺序发生了变化，这样改动最简单的方法就是在写入前直接对调顺序。
    ReDim brr(1 To UBound(xrr), 4 To UBound(arr, 2))
    For i = 1 To UBound(xrr)
        For j = 4 To UBound(arr, 2)
            brr(i, j) = arr(xrr(i), j)
        Next
    Next
    For i = 1 To UBound(brr)
        xx = brr(i, 4)
        brr(i, 4) = brr(i, 5)
        brr(i, 5) = xx
        xx = brr(i, 6)
        brr(i, 6) = brr(i, 7)
        brr(i, 7) = xx
    Next
    .[b8].Resize(i - 1, j - 4) = brr
在现有代码中插入以上红色部分即可。

love_liwu

shjarthur 发表于 2017-2-16 23:17
看了下，只是原表列的顺序发生了变化，这样改动最简单的方法就是在写入前直接对调顺序。
    ReDim brr(1  ...

好的，谢谢老师，我看看。

love_liwu

shjarthur 发表于 2017-2-16 23:17
看了下，只是原表列的顺序发生了变化，这样改动最简单的方法就是在写入前直接对调顺序。
    ReDim brr(1  ...

再问老师，如果不是相邻的，代码可否这么写？

brr（i，5）=brr（i，8）
brr（i，6）=brr（i，10）

shjarthur

love_liwu 发表于 2017-2-18 10:35
再问老师，如果不是相邻的，代码可否这么写？

brr（i，5）=brr（i，8）

不是相邻的，做法也一样，只要互换对应两列的位置即可，比如5列和8列交换
For i = 1 To UBound(brr)
    xx = brr(i, 5)
    brr(i, 5) = brr(i, 8)
    brr(i, 8) = xx
Next

love_liwu

shjarthur 发表于 2017-2-18 17:11
不是相邻的，做法也一样，只要互换对应两列的位置即可，比如5列和8列交换
For i = 1 To UBound(brr)
   ...

谢谢老师，请老师再帮我看看：
再问老师，请问这个如何修改？
http://www.excelpx.com/thread-427869-1-1.html
(出处: Excel精英培训网)