收藏73哥函数 程序---列出文件夹下所有子文件荚或者文件名

cawy113116

感谢楼主的分享

Sonnenblumen

谢谢，已收藏

树櫴希德

1. (defun StrType(a / b c d e);;字符串分离全角、符号、字母、数字,存在问题：连续小数点与数字相连不能精确分离数字和小数点
   
2.     (setq b(vl-string->list a))
   
3.     (while b
   
4.       (setq a(car b)b(cdr b)c(last d))
   
5.       (if(or(not d)
   
6.       (and(< 0 a 32)(< 0 c 32));;非打印字符
   
7.       (or(= 46 a)(= 46 c)(and(< 47 a 58)(< 47 c 58)));数字和小数点
   
8.       (vl-every'(lambda(x)(vl-some'(lambda(y)(<(car y)x(cadr y)))'((31 48)(57 65)(90 98)(122 129))))(list a c));其它字符包括小数点
   
9.       (vl-every'(lambda(x)(vl-some'(lambda(y)(<(car y)x(cadr y)))'((64 91)(96 123))))(list a c));;字母
   
10.       (and(> a 128)(> c 128)));;全角字符
    
11.   (if(> a 128)(setq d(vl-list*(car b)a d)b(cdr b))(setq d(cons a d)))
    
12.   (setq e(cons(reverse d)e)d(if(> a 128)(list(car b)a)(List a))b(if(> a 128)(cdr b)b))))
    
13.     (mapcar'vl-list->string(reverse(cons(reverse d)e))))
    

(defun StrType(a / b c d e);;字符串分离全角、符号、字母、数字,存在问题：连续小数点与数字相连不能精确分离数字和小数点<br />     (setq b(vl-string->list a))<br />     (while b<br />       (setq a(car b)b(cdr b)c(last d))<br />       (if(or(not d)<br />       (and(< 0 a 32)(< 0 c 32));;非打印字符<br />       (or(= 46 a)(= 46 c)(and(< 47 a 58)(< 47 c 58)));数字和小数点<br />       (vl-every'(lambda(x)(vl-some'(lambda(y)(<(car y)x(cadr y)))'((31 48)(57 65)(90 98)(122 129))))(list a c));其它字符包括小数点<br />       (vl-every'(lambda(x)(vl-some'(lambda(y)(<(car y)x(cadr y)))'((64 91)(96 123))))(list a c));;字母<br />       (and(> a 128)(> c 128)));;全角字符<br />   (if(> a 128)(setq d(vl-list*(car b)a d)b(cdr b))(setq d(cons a d)))<br />   (setq e(cons(reverse d)e)d(if(> a 128)(list(car b)a)(List a))b(if(> a 128)(cdr b)b))))<br />     (mapcar'vl-list->string(reverse(cons(reverse d)e))))<br />

w379106181

感谢大神分享

树櫴希德

收藏广州SCS数据转南方CASS  DAT  EXCEL VBA  

1. Sub 转换()
   
2. Dim numcol As Integer
   
3. Dim numrow As Long
   
4. Dim i As Long
   
5. Dim x As Integer
   
6. Dim numperrow As Integer
   
7. numperrow = InputBox("请输入每行要填的数据行的数目:")
   
8. 
   
9. Dim myRange As Range
   
10. Set myRange = Application.InputBox("选择区域", Type:=8)
    
11. 
    
12. myRange.Name = "数据"
    
13. 
    
14. 
    
15. Range("数据").Select
    
16. numrow = Selection.Rows.Count '数据区的行数
    
17. numcol = Selection.Columns.Count '数据区的列数
    
18. x = numperrow * numcol
    
19. 
    
20. 
    
21. Range("a1").Select
    
22. For i = 1 To numrow '以数据的每一行为单位进行剪切
    
23. Range("数据").Rows(i).Cut
    
24. ActiveSheet.Paste
    
25. Selection.Offset(, numcol).Select
    
26. If (i Mod numperrow) Then '判断是否要换行
    
27. Else: Selection.Offset(1, -x).Select
    
28. End If
    
29. Next i
    
30. End Sub

Sub 转换()<br /> Dim numcol As Integer<br /> Dim numrow As Long<br /> Dim i As Long<br /> Dim x As Integer<br /> Dim numperrow As Integer<br /> numperrow = InputBox("请输入每行要填的数据行的数目:")<br /> <br /> Dim myRange As Range<br /> Set myRange = Application.InputBox("选择区域", Type:=8)<br /> <br /> myRange.Name = "数据"<br /> <br /> <br /> Range("数据").Select<br /> numrow = Selection.Rows.Count '数据区的行数<br /> numcol = Selection.Columns.Count '数据区的列数<br /> x = numperrow * numcol<br /> <br /> <br /> Range("a1").Select<br /> For i = 1 To numrow '以数据的每一行为单位进行剪切<br /> Range("数据").Rows(i).Cut<br /> ActiveSheet.Paste<br /> Selection.Offset(, numcol).Select<br /> If (i Mod numperrow) Then '判断是否要换行<br /> Else: Selection.Offset(1, -x).Select<br /> End If<br /> Next i<br /> End Sub

树櫴希德

1. (defun chains(es fuz / e a b s pts);;链式选择，选择首尾相连的线
   
2. (setq s(ssadd))
   
3.    (while es
   
4.     (setq e(car es)es(cdr es)
   
5.     p1(mapcar'+'(0 0)(vlax-curve-getStartPoint e))p2(mapcar'+'(0 0)(vlax-curve-getendPoint e)))
   
6.     (foreach a(S2E(ssget"CP"(list p1(list(car p1)(cadr p2))p2(list(car p2)(cadr p1)))'((0 . "arc,*spline,*polyline,line"))))
   
7.       (or(SSMEMB a s)
   
8.    ((lambda()
   
9.       (setq p1(mapcar'+'(0 0)(vlax-curve-getStartPoint a))
   
10.       p2(mapcar'+'(0 0)(vlax-curve-getendPoint a)))
    
11.       (and(vl-some'(lambda(x)(or(equal p1 x fuz)(equal p2 x fuz)))pt)
    
12.     (setq es(cons a es)pt(vl-list* p1 p2 pt))
    
13.     (ssadd a s)))))))
    
14.   (sssetfirst'nil s)
    
15.   )

(defun chains(es fuz / e a b s pts);;链式选择，选择首尾相连的线<br /> (setq s(ssadd))<br />    (while es<br />     (setq e(car es)es(cdr es)<br />     p1(mapcar'+'(0 0)(vlax-curve-getStartPoint e))p2(mapcar'+'(0 0)(vlax-curve-getendPoint e)))<br />     (foreach a(S2E(ssget"CP"(list p1(list(car p1)(cadr p2))p2(list(car p2)(cadr p1)))'((0 . "arc,*spline,*polyline,line"))))<br />       (or(SSMEMB a s)<br />    ((lambda()<br />       (setq p1(mapcar'+'(0 0)(vlax-curve-getStartPoint a))<br />       p2(mapcar'+'(0 0)(vlax-curve-getendPoint a)))<br />       (and(vl-some'(lambda(x)(or(equal p1 x fuz)(equal p2 x fuz)))pt)<br />     (setq es(cons a es)pt(vl-list* p1 p2 pt))<br />     (ssadd a s)))))))<br />   (sssetfirst'nil s)<br />   )

树櫴希德

1. (defun chains(es fuz / e a b s pts)
   
2. (setq s(ssadd))
   
3.   (while es
   
4.     (setq e(car es)es(cdr es)
   
5.           p1(mapcar'+'(0 0)(vlax-curve-getStartPoint e))p2(mapcar'+'(0 0)(vlax-curve-getendPoint e)))
   
6.     (foreach a(S2E(ssget"CP"(list p1(list(car p1)(cadr p2))p2(list(car p2)(cadr p1)))'((0 . "arc,*spline,*polyline,line"))))
   
7.       (or(SSMEMB a s)
   
8.          ((lambda()
   
9.             (setq p1(mapcar'+'(0 0)(vlax-curve-getStartPoint a))
   
10.                   p2(mapcar'+'(0 0)(vlax-curve-getendPoint a)))
    
11.             (and(vl-some'(lambda(x)(or(equal p1 x fuz)(equal p2 x fuz)))pt)
    
12.                 (setq es(cons a es)pt(vl-list* p1 p2 pt))
    
13.                 (ssadd a s)))))))
    
14.   (sssetfirst'nil s))

(defun chains(es fuz / e a b s pts)<br /> (setq s(ssadd))<br />   (while es<br />     (setq e(car es)es(cdr es)<br />           p1(mapcar'+'(0 0)(vlax-curve-getStartPoint e))p2(mapcar'+'(0 0)(vlax-curve-getendPoint e)))<br />     (foreach a(S2E(ssget"CP"(list p1(list(car p1)(cadr p2))p2(list(car p2)(cadr p1)))'((0 . "arc,*spline,*polyline,line"))))<br />       (or(SSMEMB a s)<br />          ((lambda()<br />             (setq p1(mapcar'+'(0 0)(vlax-curve-getStartPoint a))<br />                   p2(mapcar'+'(0 0)(vlax-curve-getendPoint a)))<br />             (and(vl-some'(lambda(x)(or(equal p1 x fuz)(equal p2 x fuz)))pt)<br />                 (setq es(cons a es)pt(vl-list* p1 p2 pt))<br />                 (ssadd a s)))))))<br />   (sssetfirst'nil s))

树櫴希德

树櫴希德 发表于 2022-6-14 22:58
收藏广州SCS数据转南方CASS  DAT  EXCEL VBA

1. Public Sub 表格加1()
   
2. Dim myRange As Range
   
3. 
   
4. Set myRange = Application.InputBox("选择区域", Type:=8)
   
5. 
   
6. For Each x In myRange
   
7. 
   
8. x.Formula = x + 1
   
9. 
   
10. Next x
    
11. 
    
12. End Sub
    

Public Sub 表格加1()<br /> Dim myRange As Range<br /> <br /> Set myRange = Application.InputBox("选择区域", Type:=8)<br /> <br /> For Each x In myRange<br /> <br /> x.Formula = x + 1<br /> <br /> Next x<br /> <br /> End Sub<br />

树櫴希德

树櫴希德 发表于 2022-6-18 17:31

EXCEL 表格根据内容转置  但是效果不好

1. Public Sub mm()
   
2. Dim numcol As Integer
   
3. Dim numrow As Long
   
4. 'Dim mypos As Integer
   
5. Dim i As Long
   
6. 
   
7. Dim myRange As Range
   
8. Set myRange = Application.InputBox("选择区域", Type:=8)
   
9. 
   
10. myRange.Name = "数据"
    
11. 
    
12. 
    
13. Range("数据").Select
    
14. numrow = Selection.Rows.Count '数据区的行数
    
15. numcol = Selection.Columns.Count '数据区的列数
    
16. 
    
17. Range("a1").Select
    
18. 
    
19.   
    
20.   
    
21.   For Each Rng In myRange
    
22.   Rng.Cut
    
23. ActiveSheet.Paste
    
24. 
    
25. Selection.Offset(, numcol).Select
    
26. 
    
27. 
    
28. 
    
29. If (InStr(Rng, "begin") = 0) Then    '判断是否要换行   Cells(Rng + 1, 0).Select
    
30.     Else: Selection.Offset(1, -1 * Rng.Column).Select
    
31. End If
    
32. 
    
33. 
    
34. 
    
35. 
    
36. Next Rng
    
37.   
    
38. 
    
39. End Sub

Public Sub mm()<br /> Dim numcol As Integer<br /> Dim numrow As Long<br /> 'Dim mypos As Integer<br /> Dim i As Long<br /> <br /> Dim myRange As Range<br /> Set myRange = Application.InputBox("选择区域", Type:=8)<br /> <br /> myRange.Name = "数据"<br /> <br /> <br /> Range("数据").Select<br /> numrow = Selection.Rows.Count '数据区的行数<br /> numcol = Selection.Columns.Count '数据区的列数<br /> <br /> Range("a1").Select<br /> <br />   <br />   <br />   For Each Rng In myRange<br />   Rng.Cut<br /> ActiveSheet.Paste<br /> <br /> Selection.Offset(, numcol).Select<br /> <br /> <br /> <br /> If (InStr(Rng, "begin") = 0) Then    '判断是否要换行   Cells(Rng + 1, 0).Select<br />     Else: Selection.Offset(1, -1 * Rng.Column).Select<br /> End If<br /> <br /> <br /> <br /> <br /> Next Rng<br />   <br /> <br /> End Sub

gzxl

VBA？ 发贴楼主应该把自己的经典或者优化别人的分享出来。
发帖用别人的可不太好！