EXCEL VBA问题，有点难度！！

cong323 2009-08-16 03:39:31

原始数据:
A B C D
1 1a bb 0.2 2
2 1a bb 0.3 23
3 1a bb 0.4 5
4 2a bb 0.5 8
5 2a bb 0.5 8
6 2a bb 0.5 8
7 2a bb 0.5 8

目标表：
A B C D E F
1 1a bb 0.2 0.3 0.4
2 2a bb 0.5 0.5 0.5 0.5

说明：
把原始表中A,B列相同的合成目标表中的一行，同时把原始表中C列的数值放到目标表中对应的C,D,E,F中，不够的留空，没有超出4个的，最多就4条记录。

用VBA怎么写？

...全文

397 13 打赏收藏转发到动态举报

写回复

用AI写文章

13 条回复

切换为时间正序

请发表友善的回复…

发表回复

liujiaqiid 2009-08-19

打赏
举报

hao...

cong323 2009-08-18

打赏
举报

采用方法一,搞定了,谢谢大家了

liujiaqiid 2009-08-18

打赏
举报

你好，你提到的问题在我这确实没发生，我把运行后的结果（sheet2中）发给你，你再试一下你的快捷键....

如果还不行，那应该就是版本的问题，excel2007中的宏在03中并不完全支持,你可以这样：

1.在excel03中单独录制一个宏，操作步骤如下：开始录制宏----选中A、B两列----排序-----自定义排序----添加两个条件分别以A、B两列为关键字
-----确定-----停止录制宏-----去看看代码------如有像选中最后一行这种情况可用i变量替代-----将此段代码拷入星号内------再试试
（你也可以把代码贴出来，我给你改，我这没03所以没法测）

2.第二种方法是安装07....我这一点问题都没有

此致

liujiaqiid 2009-08-17

打赏
举报

建议LZ新建一个工作簿，先测试一下，在新工作簿的sheet1中放你的数据，运行代码，看下结果...

我没看到你的文件，所以效果很可能有所差异，如还有问题的话：方便的话你把工作簿发我邮箱吧
liujiaqiid@sina.com

我给你看看,,,,,,

liujiaqiid 2009-08-17

打赏
举报

您所说的438错误我这并没发现...

可能是其他操作的不一致引起的，另外代码我又测试了下，现更新如下：





'此过程完成从sheet1向sheet2有条件转移



Sub HeBing()



    Dim i As Long, j As Long, flag As Long, num As Long, x As Long



    i = Application.WorksheetFunction.CountA(Sheet1.Range("a:a")) 

   '注意，您问题中没说有表头，故我假定你的数据从第一行就开始了......

                                                                   

    

    

   '*****************星号内的代码是通过A、B两列进行排序(将ab两列相同的尽量放一起),

                    '如果您的表中已经是有序的可以将星号内的代码去掉....

   

   ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Clear

    

   ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Add Key:=Range("A1:A" & i), _

        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal

    

   ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Add Key:=Range("B1:B" & i), _

        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal

    

    With ActiveWorkbook.Worksheets("Sheet1").Sort

        .SetRange Range("A1:B" & i)

        .Header = xlGuess

        .MatchCase = False

        .Orientation = xlTopToBottom

        .SortMethod = xlPinYin

        .Apply

    

    End With

    

    '****************

    

    

    



   '===

   

   

    num = 1  '此为sheet2中的输入行数

    

    x = 1

    

    Sheet2.Range("a1:c1").Value = Sheet1.Range("a1:c1").Value  '先处理第一行

    

    'flag = 1  '此为标志位，很关键...

    

    If i <= 1 Then

    

        MsgBox "处理完！！"

    

        Exit Sub

        

    End If

     

     

    For j = 2 To i

                

       If Sheet1.Range("A" & j - 1).Value = Sheet1.Range("a" & j).Value And Sheet1.Range("b" & j - 1).Value = Sheet1.Range("b" & j).Value Then

      

             Select Case x

                  

                  Case 1

                         Sheet2.Range("d" & num).Value = Sheet1.Range("c" & j).Value

                         

                  Case 2

                         Sheet2.Range("e" & num).Value = Sheet1.Range("c" & j).Value

                             

                  Case 3

                         Sheet2.Range("f" & num).Value = Sheet1.Range("c" & j).Value

                  

                  Case Else

                                'do nothing

                                    

             End Select

             

             x = x + 1

             

        Else

            

            num = num + 1

            

            Sheet2.Range("a" & num, "c" & num).Value = Sheet1.Range("a" & j, "c" & j).Value

           

            

           x = 1

         

        End If

     

    Next j





    MsgBox "处理完！"







End Sub

cong323 2009-08-17

打赏
举报

to liujiaqiid 意思是对的
你给的代码"ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Clear"怎么出错,提示438错误,对象不支持该方法或属性
"

cong323 2009-08-17

打赏
举报

还是排序问题
'*****************星号内的代码是通过A、B两列进行排序(将ab两列相同的尽量放一起),
'如果您的表中已经是有序的可以将星号内的代码去掉....

ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Clear

ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Add Key:=Range("A1:A" & i), _
SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal

ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Add Key:=Range("B1:B" & i), _
SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal

With ActiveWorkbook.Worksheets("Sheet1").Sort
.SetRange Range("A1:B" & i)
.Header = xlGuess
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply

End With

'****************
我已经发邮件给你了

bigriverhorse 2009-08-17

打赏
举报

透视表就是用来解决这种“有难度”的工作的。

liujiaqiid 2009-08-17

打赏
举报

哇，数据透视表和强大呀....

栖云居主人 2009-08-16

打赏
举报

取消掉对行、列的总计，得到：
平均值项:N3 N3
N1 N2 0.2 0.3 0.4 0.5
1a bb 0.2 0.3 0.4
2a bb 0.5

栖云居主人 2009-08-16

打赏
举报

用万能的数据透视表：
ABC三列分别命名为N1,N2,N3
插入数据透视表
设置行标签N1,N2，取消分类汇总N2
设置列标签N3
设置数值N3(N3列应确保为数值而非文本，设置为平均值项)
选择报表布局为表格形式
结果如下：
平均值项:N3 N3
N1 N2 0.2 0.3 0.4 0.5 总计
1a bb 0.2 0.3 0.4 0.3
2a bb 0.5 0.5
总计 0.2 0.3 0.4 0.5 0.4

liujiaqiid 2009-08-16

打赏
举报

希望对您有所帮助...

liujiaqiid 2009-08-16

打赏
举报

你的意思是不是这样：表中每一行元素如果对应A、B两列值相同，则将对应地C列值依次放到新表的C、D、E、F列中，不够的空着，而多的就不管了....
以下是我的实现代码:





'此过程完成从sheet1向sheet2有条件转移



Sub HeBing()



    Dim i As Long, j As Long, flag As Long, num As Long, x As Long



    i = Application.WorksheetFunction.CountA(Sheet1.Range("a:a")) '注意，您问题中没说有表头，故我假定你的数据从第一行就开始了......

                                                                   

    

    

   '*****************星号内的代码是通过A、B两列进行排序(将ab两列相同的尽量放一起),如果您的表中已经是有序的可以将型号内的代码去掉....

   

   ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Clear

    

   ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Add Key:=Range("A1:A" & i), _

        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal

    

   ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Add Key:=Range("B1:B" & i), _

        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal

    

    With ActiveWorkbook.Worksheets("Sheet1").Sort

        .SetRange Range("A1:B" & i)

        .Header = xlGuess

        .MatchCase = False

        .Orientation = xlTopToBottom

        .SortMethod = xlPinYin

        .Apply

    

    End With

    

    '****************

    

    

    



   '===

   

   

    num = 1  '此为sheet2中的输入行数

    

    x = 1

    

    Sheet2.Range("a1:c1").Value = Sheet1.Range("a1:c1").Value  '先处理第一行

    

    'flag = 1  '此为标志位，很关键...

    

    If i <= 1 Then

    

        MsgBox "处理完！！"

    

        Exit Sub

        

    End If

     

     

    For j = 2 To i

                

       If Sheet1.Range("A" & j - 1).Value = Sheet1.Range("a" & j).Value And Sheet1.Range("b" & j - 1).Value = Sheet1.Range("b" & j).Value Then

      

             Select Case x

                  

                  Case 1

                         Sheet2.Range("d" & num).Value = Sheet1.Range("c" & j).Value

                         

                  Case 2

                         Sheet2.Range("e" & num).Value = Sheet1.Range("c" & j).Value

                             

                  Case 3

                         Sheet2.Range("f" & num).Value = Sheet1.Range("c" & j).Value

                  

                  Case Else

                                'do nothing

                                    

             End Select

             

             x = x + 1

             

        Else

           

            Sheet2.Range("a" & num, "c" & num).Value = Sheet1.Range("a" & j, "c" & j).Value

           

         '  flag = 0

           

           num = num + 1

            

           x = 1

         

        End If

     

    Next j







End Sub