ExcelHome技术论坛

 找回密码
 免费注册

QQ登录

只需一步,快速开始

EH搜索     
EH云课堂-专业的职场技能充电站 Excel转在线管理系统,怎么做看这里 Excel服务器-会Excel,做管理系统 Excel Home精品图文教程库
Excel不给力? 何不试试FoxTable! Excel 2016函数公式学习大典 EH云课堂直播课程免费学 打造核心竞争力的职场宝典
300集Office 2010微视频教程 Tableau-数据可视化工具 精品推荐-800套精选PPT模板,点击获取 ExcelHome出品 - VBA代码宝免费下载
你的Excel 2010实战技巧学习锦囊 欲罢不能, 过目难忘的 Office 新界面 Excel VBA经典代码实践指南
查看: 1979|回复: 5

[已解决] (急)通用记录折行处理函数,感谢蓝版点拨?

[复制链接]

TA的精华主题

TA的得分主题

发表于 2012-1-29 16:09 | 显示全部楼层 |阅读模式
本帖最后由 goldowl2011 于 2012-1-29 22:11 编辑

工作簿1.rar (24.65 KB, 下载次数: 16)

TA的精华主题

TA的得分主题

发表于 2012-1-29 17:39 | 显示全部楼层
  1. Sub 按钮1_Click()
  2. With ActiveWorkbook.ActiveSheet
  3.     Dim a, b, Arr
  4.     Arr = [b1].CurrentRegion
  5.     b = UBound(Arr)
  6.     a = UBound(Arr, 2)
  7.     MsgBox "maxcol=" & a & Chr(10) & " maxrow=" & b
  8. End With
  9. End Sub
复制代码
用这个试试看。

TA的精华主题

TA的得分主题

 楼主| 发表于 2012-1-29 18:05 | 显示全部楼层
本帖最后由 goldowl2011 于 2012-1-29 19:01 编辑

感谢版主亲自解答,用的.CurrentRegion可以得到正确的列数,太感谢了!在写一个批量文本导入处理程序,多行表头,多行表尾,记录折行处理等等,哈哈!有坛子真好,真是受用无穷呀!

另我想再问一下,我如果要取出每一行的有效最大列,应如何修改您的代码?
因我要进行记录的折行处理,如将三行数据(属于一条记录)合并到第一行中,如此类推,最终将导入文本转化成一个标准的二维表!
请版主指教,谢谢!!!

Sub testzh()
Call 通用折行处理(1, "1", 8, 3, 1, 100)
End Sub

Public Function 通用折行处理(ByVal TCol&, ByVal TChar$, ByVal TNum&, ByVal RecMultiLines&, ByVal StartLine&, ByVal EndLine&, Optional ByVal WCol&, Optional ByVal WChar$, Optional ByVal WNum&)
'表头判断列,表头判断内容,表头总行数,记录折行数,开始处理行,结束处理行,表尾判断列(可选),表尾判断内容(可选),表尾总行数(可选) 9个参数

'On Error Resume Next
Application.DisplayAlerts = False
Application.ScreenUpdating = False

Dim i&, j&, k&, p&
Dim maxLine&, maxCol&
Dim str1$, str2$, str3$
Dim arr1, arr2, arr3

'是用字典好,还是用数组好?
'Set ZH1 = CreateObject("Scripting.Dictionary")
'Set ZH2 = CreateObject("Scripting.Dictionary")
'Set ZH3 = CreateObject("Scripting.Dictionary")

'===============================以下可在函数化时进行参数化改造
'Dim StartLine&, RecMultiLines&, EndLine&, MaxFieldperLine
'StartLine = 1           '开始行,一般在A列判断=空即为记录行
'RecMultiLines = 3       '每条记录的折行数
'EndLine = 42           '查询结束行
'MaxFieldperLine = 8     '每行字段数量

With ActiveWorkbook.ActiveSheet
    Dim MaxArr
    MaxArr = .[A1].CurrentRegion
    'maxLine = UBound(MaxArr)
    maxCol = UBound(MaxArr, 2)
    maxLine = .UsedRange.Columns.count

   MsgBox maxCol & "|" & maxLine

   ReDim arr1(1 To maxCol)

'-------------------------
'step1:  记录折行合一处理
'-------------------------
   For i = StartLine To EndLine
       If Trim(.Cells(i, TCol)) Like "*" & TChar & "*" Then     '判断表头开始行
           i = i + TNum
           For k = 1 To (RecMultiLines - 1)
             '.Cells((i + k), 1).Resize(, .Range("IV" & (i + k)).End(xlToLeft).Column).Copy .Cells(i, .Range("IV" & i).End(xlToLeft).Column + 1)  '可以会出现空列

               arr1 = .Range(.Cells((i + k), 1), .Cells((i + k), maxCol))   '数组取不到数据?

                For j = 1 To UBound(arr1)
                      .Cells(i, .Range("IV" & i).End(xlToLeft).Column + 1) = arr1(j)   '此处报错下标越界了?
                Next j

                '给已合并记录行打标识,在第1列上打一个星号*,以便最后删除行操作。
                .Cells((i + k), 1) = "*"

           Next k
           i = i + RecMultiLines - 1
      Else
            For k = 1 To (RecMultiLines - 1)
              .Cells((i + k), 1).Resize(, .Range("IV" & (i + k)).End(xlToLeft).Column).Copy .Cells(i, .Range("IV" & i).End(xlToLeft).Column + 1)  '可以会出现空列

              ' ReDim arr1(0 To .Range("IV" & (i + k)).End(xlToLeft).Column - 1)
               arr1 = .Range(.Cells((i + k), 1), .Cells((i + k), maxCol))

                For j = 1 To UBound(arr1)
                      .Cells(i, .Range("IV" & i).End(xlToLeft).Column + 1) = arr1(j)
                Next j
                    '给已合并记录行打标识,在第1列上打一个星号*,以便最后删除行操作。
                    .Cells((i + k), 1) = "*"

               Next k
               i = i + RecMultiLines - 1


       End If


   Next i

'-------------------------
'step2:删除已合并的记录行
'-------------------------

















End With




Application.DisplayAlerts = True
Application.ScreenUpdating = True

End Functio

测试数据:
testdata.rar (25.17 KB, 下载次数: 15)

TA的精华主题

TA的得分主题

发表于 2012-1-29 19:03 | 显示全部楼层

TA的精华主题

TA的得分主题

 楼主| 发表于 2012-1-29 22:07 | 显示全部楼层
本帖最后由 goldowl2011 于 2012-1-29 22:08 编辑

已根据蓝版的帮助重写了代码,针对无表尾只有表头的记录折行处理已经成功,特发此处!下一步将添加含表尾的分支处理的完整函数,哈哈!

Sub testzh()
Call 通用折行处理(1, "1", 8, 3, 1, 100)
End Sub

Public Function 通用折行处理(ByVal TCol&, ByVal TChar$, ByVal TNum&, ByVal RecMultiLines&, ByVal StartLine&, ByVal EndLine&, Optional ByVal WCol&, Optional ByVal WChar$, Optional ByVal WNum&)
'表头判断列,表头判断内容,表头总行数,记录折行数,开始处理行,结束处理行,表尾判断列(可选),表尾判断内容(可选),表尾总行数(可选) 9个参数

'On Error Resume Next
Application.DisplayAlerts = False
Application.ScreenUpdating = False

Dim i&, j&, k&, p&, q&
Dim maxLine&, maxCol&
Dim str1$, str2$, str3$
Dim arr1, arr2, arr3

With ActiveWorkbook.ActiveSheet
    Dim MaxArr
    MaxArr = .[A1].CurrentRegion
    'maxLine = UBound(MaxArr)
    maxCol = UBound(MaxArr, 2)
    maxLine = .UsedRange.Columns.Count

   'MsgBox maxCol & "|" & maxLine

   ReDim arr1(maxCol)

'-------------------------
'step1:  记录折行合一处理
'-------------------------
   For i = StartLine To EndLine
       If Trim(.Cells(i, TCol)) Like "*" & TChar & "*" Then     '判断表头开始行
           i = i + TNum
           For k = 1 To (RecMultiLines - 1)
                  ReDim arr1(maxCol)

               For p = 0 To .Cells((i + k), "iv").End(xlToLeft).Column - 1
                    If Trim(.Cells(i + k, p + 1)) <> "" Then arr1(p) = .Cells(i + k, p + 1)
               Next p
               
               ' MsgBox arr1(1)
               
                For j = 0 To UBound(arr1)
                      .Cells(i, .Cells(i, "iv").End(xlToLeft).Column + 1) = arr1(j)
                Next j

                '给已合并记录行打标识,在第1列上打一个星号*,以便最后删除行操作。
                .Cells((i + k), 1) = "*"

           Next k
           i = i + RecMultiLines - 1
      Else
            For k = 1 To (RecMultiLines - 1)
                 ReDim arr1(maxCol)
               
               For p = 0 To .Cells((i + k), "iv").End(xlToLeft).Column - 1
                    If Trim(.Cells(i + k, p + 1)) <> "" Then arr1(p) = .Cells(i + k, p + 1)
                    
               Next p
               
               ' MsgBox arr1(1)
               
                For j = 0 To UBound(arr1)
                      .Cells(i, .Cells(i, "iv").End(xlToLeft).Column + 1) = arr1(j)  
                Next j

                '给已合并记录行打标识,在第1列上打一个星号*,以便最后删除行操作。
                .Cells((i + k), 1) = "*"

           Next k
           i = i + RecMultiLines - 1

       End If


   Next i

'-------------------------
'step2:删除已合并的记录行
'-------------------------
For q = maxLine To 1 Step -1
    If .Cells(q, 1) = "*" Then .Cells(q, 1).EntireRow.Delete
   
Next q


End With



MsgBox "记录折行处理结束!", 64, "提示"
Application.DisplayAlerts = True
Application.ScreenUpdating = True

End Function

TA的精华主题

TA的得分主题

 楼主| 发表于 2012-1-29 22:35 | 显示全部楼层
带表头以及表尾处理的完整的折行处理函数示例,已经成功了!特此留下脚印

Sub testzh2()
Call 通用折行处理2(1, "1", 8, 3, 1, 114, 2, "BW", 2)
End Sub


Public Function 通用折行处理2(ByVal TCol&, ByVal TChar$, ByVal TNum&, ByVal RecMultiLines&, ByVal StartLine&, ByVal EndLine&, Optional ByVal WCol&, Optional ByVal WChar$, Optional ByVal WNum&)
'表头判断列,表头判断内容,表头总行数,记录折行数,开始处理行,结束处理行,表尾判断列(可选),表尾判断内容(可选),表尾总行数(可选) 9个参数
'含表尾处理

'On Error Resume Next
Application.DisplayAlerts = False
Application.ScreenUpdating = False

Dim i&, j&, k&, p&, q&
Dim maxLine&, maxCol&
Dim str1$, str2$, str3$
Dim arr1, arr2, arr3

With ActiveWorkbook.ActiveSheet
    Dim MaxArr
    MaxArr = .[A1].CurrentRegion
    'maxLine = UBound(MaxArr)
    maxCol = UBound(MaxArr, 2)
    maxLine = .UsedRange.Columns.Count

   'MsgBox maxCol & "|" & maxLine

   ReDim arr1(maxCol)

'-------------------------
'step1:  记录折行合一处理
'-------------------------
   For i = StartLine To EndLine
       If Trim(.Cells(i, TCol)) Like "*" & TChar & "*" Then     '判断表头开始行
           i = i + TNum
           For k = 1 To (RecMultiLines - 1)
                  ReDim arr1(maxCol)

               For p = 0 To .Cells((i + k), "iv").End(xlToLeft).Column - 1
                    If Trim(.Cells(i + k, p + 1)) <> "" Then arr1(p) = .Cells(i + k, p + 1)
               Next p
               
               ' MsgBox arr1(1)
               
                For j = 0 To UBound(arr1)
                      .Cells(i, .Cells(i, "iv").End(xlToLeft).Column + 1) = arr1(j)  '此处报错下标越界了?
                Next j

                '给已合并记录行打标识,在第1列上打一个星号*,以便最后删除行操作。
                .Cells((i + k), 1) = "*"

           Next k
           i = i + RecMultiLines - 1
      
      ElseIf Trim(.Cells(i, WCol)) Like "*" & WChar & "*" Then     '判断表尾开始行
            i = i + WNum - 1
           
      
      
      Else
            For k = 1 To (RecMultiLines - 1)
                 ReDim arr1(maxCol)
               
               For p = 0 To .Cells((i + k), "iv").End(xlToLeft).Column - 1
                    If Trim(.Cells(i + k, p + 1)) <> "" Then arr1(p) = .Cells(i + k, p + 1)
                    
               Next p
               
               ' MsgBox arr1(1)
               
                For j = 0 To UBound(arr1)
                      .Cells(i, .Cells(i, "iv").End(xlToLeft).Column + 1) = arr1(j)  '此处报错下标越界了?
                Next j

                '给已合并记录行打标识,在第1列上打一个星号*,以便最后删除行操作。
                .Cells((i + k), 1) = "*"

           Next k
           i = i + RecMultiLines - 1

       End If


   Next i

'-------------------------
'step2:删除已合并的记录行
'-------------------------
For q = maxLine To 1 Step -1
    If .Cells(q, 1) = "*" Then .Cells(q, 1).EntireRow.Delete
Next q


End With



MsgBox "记录折行处理结束!", 64, "提示"
Application.DisplayAlerts = True
Application.ScreenUpdating = True

End Function

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

本版积分规则

关注官方微信,高效办公专列,每天发车

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

GMT+8, 2019-10-19 12:12 , Processed in 0.072538 second(s), 15 queries , Gzip On, MemCache On.

Powered by Discuz! X3.4

© 1999-2020 Wooffice Inc.

   

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

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

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