博客

Sub SplitData()
    Dim NewArr(1 To 200, 1 To 2)
    For Each sht In ThisWorkbook.Worksheets
       Erase NewArr
       arr = sht.[a1].CurrentRegion
       'arr = sht.Range("a1:b10")
       
       If (IsEmpty(arr)) Then            '空表处理
          sht.Delete
       Else
                  
           NewArr(1, 1) = arr(1, 1)       '拷贝表头
           NewArr(1, 2) = arr(1, 2)
           k = 2
           
           For i = 2 To UBound(arr, 1)
           
               adt = Replace(arr(i, 2), "，", "、")  '替换
               adt = Replace(adt, "。", "、")
               adt = Replace(adt, ".", "、")
               adt = Replace(adt, ",", "、")
               
               If (Len(adt) > 0) Then               '单元格不为空
               
                   adt_list = Split(adt, "、")       '拆分
                   
                   For j = 0 To UBound(adt_list, 1)   '循环写入
                   
                        If (Len(adt_list(j)) > 0) Then  '避免开头和结尾是标点
                        
                            NewArr(k, 1) = arr(i, 1)
                            NewArr(k, 2) = adt_list(j)
                            k = k + 1
                            
                        End If
                        
                   Next
                   
               End If
               
           Next
           
           sht.[f3].Resize(UBound(NewArr, 1), 2) = NewArr
           
       End If
       
     Next
    
End Sub

处理前：

处理后：