原文链接：http://www.cnblogs.com/riceLee/archive/2013/03/18/2966766.html

Sub doLoop()
    Dim lwxm As String
    Dim dydw As String
    
    Dim temp As String
    
    ' Sheet4.Rows.Count
    Dim res() As Integer
    Dim index As Integer
    
    Dim lwxmIndex As Integer
    
    ' 定义劳务项目名称所在列索引
    lwxmIndex = 4
    
    
    For i = 1 To 247
    
        ' 如果劳务项目列为空，跳出循环
        If Sheet4.Cells(1, 2) = "" Then
            Exit For
        End If
            
        ReDim res(247)
        res(0) = 1
        index = 1
        
         ' 将原始数据第一行复制到新sheet
         Sheet5.Cells(i, 1) = Sheet4.Cells(1, 1)
         Sheet5.Cells(i, 2) = Sheet4.Cells(1, 2)
         Sheet5.Cells(i, 3) = Sheet4.Cells(1, 3)
         
         lwxm = Sheet4.Cells(1, 2)
         dydw = Sheet4.Cells(1, lwxmIndex)
         
         ' 循环查找和第一列劳务项目名称相同的单元格，相同则加入到新的对应单位字符串中
         
         For j = 2 To 247
            temp = Sheet4.Cells(j, 2)
                If temp <> "" And lwxm = temp Then
                  dydw = dydw + "、" + Sheet4.Cells(j, lwxmIndex)
                  ' 记录匹配成功的行号
                  
                  res(index) = j
                  index = index + 1
             End If
         Next
         ' 将新的对应单位赋值给新sheet
         Sheet5.Cells(i, lwxmIndex) = dydw
         ' 删除原始数据中匹配完成的行

        For m = UBound(res) To 0 Step -1
            If res(m) > 0 Then
            
            Sheet4.Range(res(m) & ":" & res(m)).Delete shift:=xlShiftUp
            End If
            
         Next
    
    Next
    
    'Sheet4.Cells(1, 5) = str
    
    
End Sub

今天要处理一个excel表格，大体目标：把相同劳务项目的行合并，并将对应单位合并到一个单元格里面。

程序很烂，而且可重用性基本没有。

初次接触，纯粹练手。

转载于:https://www.cnblogs.com/riceLee/archive/2013/03/18/2966766.html