ExcelHome技术论坛

 找回密码
 免费注册

QQ登录

只需一步,快速开始

快捷登录

搜索
EH技术汇-专业的职场技能充电站 妙哉!函数段子手趣味讲函数 Excel服务器-会Excel,做管理系统 效率神器,一键搞定繁琐工作
HR薪酬管理数字化实战 Excel 2021函数公式学习大典 Excel数据透视表实战秘技 打造核心竞争力的职场宝典
让更多数据处理,一键完成 数据工作者的案头书 免费直播课集锦 ExcelHome出品 - VBA代码宝免费下载
用ChatGPT与VBA一键搞定Excel WPS表格从入门到精通 Excel VBA经典代码实践指南
查看: 124|回复: 3

学习合并单元格

[复制链接]

TA的精华主题

TA的得分主题

发表于 2024-10-4 15:51 | 显示全部楼层 |阅读模式
本帖最后由 ning84 于 2024-10-4 16:15 编辑

image.png


  1. Sub lll()
  2.    Dim Rng As Range, oRng As Range
  3.    Dim Sht As Worksheet, Sht1 As Worksheet
  4.        Set Sht = Sheet1
  5.        Set Sht1 = Sheet2
  6.        Sht1.Cells.Clear
  7.       
  8.    Dim Shp As Shape
  9.    
  10.    Dim Rr, Kk, Str
  11.        Rr = 10
  12.       
  13.        For Each Shp In Sht.Shapes
  14.               Debug.Print Shp.Name
  15.        Next Shp
  16.        With Sht
  17.             Debug.Print .Cells(655536, 1).End(xlUp).Row, .Cells(1, 1).End(xlDown).Row
  18.             Set Rng = .Cells(1, 1).End(xlDown)
  19.             Set Rng = .Range(.Cells(.Cells(1, 1).End(xlDown).Row, 1), .Cells(.Cells(655536, 1).End(xlUp).Row + 1, 1))
  20.         End With
  21.        For ii = 1 To Rng.Rows.Count
  22.             If InStr(Rng(ii, 1), "澳門 >") > 0 Then
  23.                 Str = Rng(ii, 1)
  24.             End If
  25.             If Rng(ii, 1) <> "" Then
  26.                If Asc(Rng(ii, 1)) >= 65 And Asc(Rng(ii, 1)) <= 122 Then
  27.                     Sht1.Cells(Rr, 1) = Str
  28.                     Sht1.Cells(Rr, 2) = Rng(ii, 1)
  29.                     Sht1.Cells(Rr, 3) = Rng(ii + 1, 1)
  30.                     Rr = Rr + 1
  31.                End If
  32.             End If
  33.        Next ii
  34. End Sub
复制代码
image.png


结果不是目标需求,需要进一步优化代码。

image.png


这段语句没有用好。。               
If Sht1.Cells(Rr, 1) = Sht1.Cells(Rr - 1, 1) Then
                   Kk = Kk + 1
               Else
                   Sht1.Cells(ii - Kk + 1, 1).Interior.ColorIndex = 4
                   'Sht1.Cells(ii - Kk, 1).Resize(Kk, 1).Interior.ColorIndex = 4
                   Kk = 1
                 'Stop
               End If





澳门公交1.zip

101.28 KB, 下载次数: 7

TA的精华主题

TA的得分主题

发表于 2024-10-5 11:21 | 显示全部楼层
楼主是分享代码,还是需要解决代码问题?

TA的精华主题

TA的得分主题

发表于 2024-10-5 11:24 | 显示全部楼层

TA的精华主题

TA的得分主题

 楼主| 发表于 2024-10-5 13:25 | 显示全部楼层
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用  · 内置多项VBA编程加强工具       ★ 免费下载 ★      ★使用手册

谢谢回复,不太会用数组法。还需要进一步消化理解。
现在还在钻牛角尖,没有出来。

*********************
$A$48         $A$10         澳门 > 北区-1(青洲区、筷子基区及林茂塘区)
$A$49         $A$10         澳门 > 北区-1(青洲区、筷子基区及林茂塘区)
$A$50         $A$10         澳门 > 北区-1(青洲区、筷子基区及林茂塘区)
$A$51         $A$10         澳门 > 北区-1(青洲区、筷子基区及林茂塘区)
$A$53         $A$52         澳门 > 北区-2(台山区、黑沙环及佑汉区)
$A$54         $A$52         澳门 > 北区-2(台山区、黑沙环及佑汉区)


            If InStr(Rng(ii, 1), "澳門 >") > 0 Then
                Str = FtoJ(Rng(ii, 1))
                Set oRng = Sht1.Cells(Rr, 1)
            End If
            
A10变成A52时,条件语句没有用好。

                    If Sht1.Cells(Rr, 1) <> oRng Then
                        Debug.Print Sht1.Cells(Rr, 1).Address, oRng.Address, oRng
                        
                    End If



*************************




  1. Sub lll()
  2.    Dim Rng As Range, oRng As Range
  3.    Dim Sht As Worksheet, Sht1 As Worksheet
  4.        Set Sht = Sheet1
  5.        Set Sht1 = Sheet2
  6.        Sht1.Cells.Clear
  7.       
  8.    Dim Shp As Shape
  9.    
  10.    Dim Rr, Kk, Str
  11.        Rr = 10

  12.        With Sht
  13.             Debug.Print .Cells(655536, 1).End(xlUp).Row, .Cells(1, 1).End(xlDown).Row
  14.             Set Rng = .Cells(1, 1).End(xlDown)
  15.             
  16.             'Set Rng = Rng.Resize(.Cells(655536, 1).End(xlUp).Row - Rng.Row + 1)
  17.             Set Rng = .Range(.Cells(.Cells(1, 1).End(xlDown).Row, 1), .Cells(.Cells(655536, 1).End(xlUp).Row + 1, 1))
  18.             Debug.Print Rng.Address
  19.        End With
  20.        For ii = 1 To Rng.Rows.Count
  21.             If InStr(Rng(ii, 1), "澳門 >") > 0 Then
  22.                 Str = FtoJ(Rng(ii, 1))
  23.                 Set oRng = Sht1.Cells(Rr, 1)
  24.             End If

  25.             If Rng(ii, 1) <> "" Then
  26.                
  27.                If Asc(Rng(ii, 1)) >= 65 And Asc(Rng(ii, 1)) <= 122 Then


  28.                     If Sht1.Cells(Rr, 1) <> oRng Then
  29.                         Debug.Print Sht1.Cells(Rr, 1).Address, oRng.Address, oRng
  30.                         
  31.                     End If
  32.                     Sht1.Cells(Rr, 1) = Str
  33.                     'Debug.Print Sht1.Cells(Rr, 1).Address, oRng.Address, Sht1.Cells(Rr, 1), oRng
  34.                     Sht1.Cells(Rr, 2) = Rng(ii, 1)
  35.                     Sht1.Cells(Rr, 3) = FtoJ(Rng(ii + 1, 1))
  36.                     
  37.                
  38.                Rr = Rr + 1
  39.                End If
  40.             End If
  41.             '
  42.                 'Debug.Print Rng(ii, 1), Rng(ii + 2, 1)
  43.             'End If
  44.        Next ii
  45.       

  46. End Sub

复制代码

澳门公交1.zip

40.48 KB, 下载次数: 2

您需要登录后才可以回帖 登录 | 免费注册

本版积分规则

手机版|关于我们|联系我们|ExcelHome

GMT+8, 2024-11-19 05:35 , Processed in 0.039113 second(s), 12 queries , Gzip On, MemCache On.

Powered by Discuz! X3.4

© 1999-2023 Wooffice Inc.

沪公网安备 31011702000001号 沪ICP备11019229号-2

本论坛言论纯属发表者个人意见,任何违反国家相关法律的言论,本站将协助国家相关部门追究发言者责任!     本站特聘法律顾问:李志群律师

快速回复 返回顶部 返回列表