提取及拆分后保持数据原格式不变

SCWYZJ

求助：文件中的电话格式是从别处用VBA提取出来的，但是只要一激活就变成负数了。我想把总表以电话为条件进行拆分，但拆分后的分表中的电话格式也变成负数了，（见附件）我想把所有表中的电话格式保持带小括号的原格式不变，激活后也不变。该如何操作，尤其在vba代码中如修改代码来实现。烦请老师帮忙看看，谢谢

ykcbf1100

格式设置的问题。

ykcbf1100

参与一下。。。

1. Sub ykcbf()  '//2024.5.14
   
2.     Dim arr, brr, d
   
3.     Set d = CreateObject("scripting.dictionary")
   
4.     Application.ScreenUpdating = False
   
5.     Application.DisplayAlerts = False
   
6.     Dim tm: tm = Timer
   
7.     Set ws = ThisWorkbook
   
8.     Set sh = ws.Sheets("Sheet1")
   
9.     bt = 1: col = 3
   
10.     For Each sht In Sheets
    
11.         If sht.Name <> sh.Name Then sht.Delete
    
12.     Next
    
13.     arr = sh.UsedRange
    
14.     For i = bt + 1 To UBound(arr)
    
15.         s = arr(i, col)
    
16.         If Not d.Exists(s) Then
    
17.             Set d(s) = CreateObject("scripting.dictionary")
    
18.         End If
    
19.         d(s)(i) = Application.Index(arr, i)
    
20.     Next i
    
21.     For Each k In d.keys
    
22.         sh.Copy after:=Sheets(Sheets.Count)
    
23.         Set sht = Sheets(Sheets.Count)
    
24.         m = d(k).Count
    
25.         With sht
    
26.             .Name = k
    
27.             .UsedRange.Offset(m + bt).Clear
    
28.             .DrawingObjects.Delete
    
29.             .Cells(bt + 1, 1).Resize(m, UBound(arr, 2)) = Application.Rept(d(k).Items, 1)
    
30.             Columns(3).NumberFormatLocal = "0_);[红色](0)"
    
31.         End With
    
32.     Next k
    
33.     sh.Activate
    
34.     Set d = Nothing
    
35.     Application.DisplayAlerts = True
    
36.     Application.ScreenUpdating = True
    
37.     MsgBox "共用时：" & Format(Timer - tm) & "秒！"
    
38. End Sub
    
39. 
    
40. 
    

复制代码

木槿花西月锦绣

试了试，设置位文本格式就好了

    Columns("C:C").NumberFormatLocal = "@"

cnmlgb9998

不关格式的事！ 去掉 如图 剪头处后面原有的  .Value !!!!!!!!!

ykcbf1100

cnmlgb9998 发表于 2024-5-14 21:02
不关格式的事！ 去掉 如图 剪头处后面原有的  .Value !!!!!!!!!

仅删除.value并不够，拆分后的表除第一个表，其它表都是还带有负号。
不信的话，你上传附件看看。

cnmlgb9998

ykcbf1100 发表于 2024-5-14 21:24
仅删除.value并不够，拆分后的表除第一个表，其它表都是还带有负号。
不信的话，你上传附件看看。

的确。。。。。。加个循环遍历。所有元素前面加个 '   即可解决。不想搞了

ykcbf1100

cnmlgb9998 发表于 2024-5-14 21:25
的确。。。。。。加个循环遍历。所有元素前面加个 '   即可解决。不想搞了

数组写入表格前，对于需要文本处理的如身份证号这样的，就要先对该列进行格式设置。这个电话号码，其实也是带有一种数字格式的，需要先设置一下。

剑指E

1. Sub 工作表拆分() '通过筛选方法完成需求，速度快，但当有合并单元格时就不能用。读者可以根据实际情况选用
   
2.     Application.ScreenUpdating = False  '关闭屏幕更新，加快执行速度
   
3.     Dim sh As Worksheet, r&, i&
   
4.     Set sh = Sheets("sheet1")
   
5.     With sh
   
6.         r = .Cells(Rows.Count, 3).End(xlUp).Row
   
7.         Worksheets.Add , sh, r - 1
   
8.         For i = 2 To r
   
9.             Union(.[a1], .Cells(i, 1)).EntireRow.Copy Sheets(i).[a1]
   
10.             .UsedRange.EntireColumn.Copy
    
11.             With Sheets(i)
    
12.                 .Select
    
13.                 .[a1].PasteSpecial 8, xlNone
    
14.                 .[c2] = "'" & .[c2].Text
    
15.                 .Name = Replace(Replace(sh.Cells(i, 3).Text, "(", ""), ")", "")
    
16.             End With
    
17.         Next
    
18.     End With
    
19.     Application.ScreenUpdating = True  '恢复屏幕更新
    
20.     MsgBox "拆分完毕！", 64, "友情提示"
    
21. End Sub
    

复制代码

wowo000

剑指E 发表于 2024-5-14 22:38

尊敬的剑指E老师：如果是多条件拆分，如何编写VBA语句？假如楼主的附件里B列有“胡声红“””两个或者更多，俺想以B列为拆分条件，将“胡声红”及“胡梦银”两个人的拆成一个表，其他人拆成一个表，咋整？恳请赐教。谢谢！