[已解决]各单位间留空几列，留空列可以增删

韩立 · 发表于 2022-1-27 17:52

本帖最后由韩立于 2022-1-27 18:03 编辑

根据sheet名增量更新2.rar (50.9 KB, 下载次数: 5)

2022-1-27 17:53 上传
点击文件名下载附件

n = Asc(UCase(Left(NM, 1))) - 64 '求列号（序号）a
   If n > 0 And n < 27 Then
--------------------------------------------------------------------------------------------------------
需求：
1、sheet名的ABCD 可以是vba允许的任意字符用于分门别类更灵活

2、各单位间留空5列可以修改

3、增删列

代码还请老师注释一下  感谢
--------------------------------------------------------------------------------------------------------

A1       b       c       d       e5       F       g       h       i       j9       k10       l       m       n       o       p       q       r       s       t       u       v       w       x       y       z
65       98       99       100       101       70       103       104       105       106       107       108       109       110       111       112       113       114       115       116       117       118       119       120       121       122

甲单位

乙单位

丙单位

丁单位

所有单位

最佳答案

zjdh

2022-1-27 17:52

你再试试
Private Sub Worksheet_Activate()
If Range("A201") = "" Then
      Range("A1：AZ1").ClearContents  '清除数据
      JG = InputBox("请输入各单位间隔空列数：", "间距设置", 5)
      If JG <> "" Then
         Range("A201") = JG
         ARR = Array("甲单位", "乙单位", "丙单位", "丁单位", "所有单位") '列标内容
         For I = 0 To UBound(ARR)
            Cells(1, I * (JG + 1) + 1) = ARR(I) '输入列标
         Next
      Else
         JG = 5
      End If
Else: Exit Sub
End If
Range("A4：AZ200").ClearContents  '清除数据
For Sh = 3 To Sheets.Count
      NM = Sheets(Sh).Name
      N = (Asc(UCase(Left(NM, 1))) - 64)
      If N > 0 And N < 27 Then
         N = (N - 1) * (JG + 1) + 1  '求列号（序号）
         W = Cells(200, N).End(3).Row + 1 '求最后一行+1
         If W < 4 Then W = 4 '避免数据落入前3行
         With Cells(W, N)
            .Select
            .Hyperlinks.Add Anchor:=Selection, Address:="", SubAddress:=NM & "!A1", TextToDisplay:=NM '添加超链接
            .Font.Name = "宋体"
            .Font.Size = 14
         End With
         N2 = UBound(ARR) * (JG + 1) + 1
         W2 = Cells(500, N2).End(3).Row + 1 '求最后一行+1
         If W2 < 4 Then W2 = 4 '避免数据落入前3行
         With Cells(W2, N2)
            .Select
            .Hyperlinks.Add Anchor:=Selection, Address:="", SubAddress:=NM & "!A1", TextToDisplay:=NM '添加超链接
            .Font.Name = "宋体"
            .Font.Size = 14
         End With
      Else
         N2 = UBound(ARR) * (JG + 1) + 1
         W = Cells(500, N2).End(3).Row + 1
         If W < 4 Then W = 4
         With Cells(W, N2)
            .Select
            .Hyperlinks.Add Anchor:=Selection, Address:="", SubAddress:=NM & "!A1", TextToDisplay:=NM
            .Font.Name = "宋体"
            .Font.Size = 14
         End With
      End If
Next
End Sub

跳转到最佳答案楼层

zjdh · 发表于 2022-1-27 17:52

你再试试
Private Sub Worksheet_Activate()
If Range("A201") = "" Then
      Range("A1：AZ1").ClearContents  '清除数据
      JG = InputBox("请输入各单位间隔空列数：", "间距设置", 5)
      If JG <> "" Then
         Range("A201") = JG
         ARR = Array("甲单位", "乙单位", "丙单位", "丁单位", "所有单位") '列标内容
         For I = 0 To UBound(ARR)
            Cells(1, I * (JG + 1) + 1) = ARR(I) '输入列标
         Next
      Else
         JG = 5
      End If
Else: Exit Sub
End If
Range("A4：AZ200").ClearContents  '清除数据
For Sh = 3 To Sheets.Count
      NM = Sheets(Sh).Name
      N = (Asc(UCase(Left(NM, 1))) - 64)
      If N > 0 And N < 27 Then
         N = (N - 1) * (JG + 1) + 1  '求列号（序号）
         W = Cells(200, N).End(3).Row + 1 '求最后一行+1
         If W < 4 Then W = 4 '避免数据落入前3行
         With Cells(W, N)
            .Select
            .Hyperlinks.Add Anchor:=Selection, Address:="", SubAddress:=NM & "!A1", TextToDisplay:=NM '添加超链接
            .Font.Name = "宋体"
            .Font.Size = 14
         End With
         N2 = UBound(ARR) * (JG + 1) + 1
         W2 = Cells(500, N2).End(3).Row + 1 '求最后一行+1
         If W2 < 4 Then W2 = 4 '避免数据落入前3行
         With Cells(W2, N2)
            .Select
            .Hyperlinks.Add Anchor:=Selection, Address:="", SubAddress:=NM & "!A1", TextToDisplay:=NM '添加超链接
            .Font.Name = "宋体"
            .Font.Size = 14
         End With
      Else
         N2 = UBound(ARR) * (JG + 1) + 1
         W = Cells(500, N2).End(3).Row + 1
         If W < 4 Then W = 4
         With Cells(W, N2)
            .Select
            .Hyperlinks.Add Anchor:=Selection, Address:="", SubAddress:=NM & "!A1", TextToDisplay:=NM
            .Font.Name = "宋体"
            .Font.Size = 14
         End With
      End If
Next
End Sub

zjdh · 发表于 2022-1-29 09:48

根据sheet名增量更新3.rar (40.7 KB, 下载次数: 10)

韩立 · 发表于 2022-2-13 19:50

本帖最后由韩立于 2022-2-13 20:07 编辑

zjdh 发表于 2022-1-29 09:48

新年好  老师

测试了下基本可用
A4:A200,G4:G200,M4:M200,S4:S200,Y4:Y200 清除数据范围调了下空的中间五格有公式

不知是不是 Excel版本问题哈我是07 精简版 sheet中文的话下面命令出错    1004  应用程序定义或对象定义错误
W = Cells(500, N2).End(3).Row + 1

sheet带字母暂时OK 的

因为试试那个sheet您是添加进去了的但是我吧A201数据去掉后就会报错

韩立 · 发表于 2022-2-13 20:12

zjdh 发表于 2022-1-29 09:48

老师

还有一个就是A201 单元格

不知是版本还是设置问题并不会自动运行我只好做了按钮出来

zjdh · 发表于 2022-2-13 23:10

不知你的系统如何，我这Win7+Excel2007环境运行正常！
A201 单元格清零后，不会自动运行，可能是你的Excel禁用事件触发，写一个宏运行一次后再试试。
SUB TEST()
Application.EnableEvents =True
END SUB

韩立 · 发表于 2022-2-13 23:32

本帖最后由韩立于 2022-2-13 23:34 编辑

zjdh 发表于 2022-2-13 23:10
不知你的系统如何，我这Win7+Excel2007环境运行正常！
A201 单元格清零后，不会自动运行，可能是你的Excel ...

谢谢老师

我的环境和您一样的

我说的不会自动运行

Private Sub Workbook_NewSheet(ByVal Sh As Object) '在工作簿中新建工作表时执行程序(固定格式)
Sheets("汇总").Range("A201") = "" '<工作表>("汇总" )的<单元格>区域("A201")=空值
End Sub '子程序结束

是这段不会按道理是新建表即执行
  所以按钮解决了

现在就是中文sheet名  会1004报错
W = Cells(500, N2).End(3).Row + 1  代码提示

字母就暂时还没发现正在和源文件合并调试

源文件空的列有公式

		自动登录	找回密码
密码			注册

[已解决]各单位间留空几列， 留空列可以增删

最佳答案

[已解决]各单位间留空几列，留空列可以增删