如何将A列到C列段落连续，后面几列有数的单元格所在列相同的合并到一起

翁知江安

Sub hz1213()
Dim i, j, k, m, p, q, g1, g2, g3, g4, g5, g6, irow, irow1, icolumn, icolumn1, icolumn2
Dim tepar, ar
Dim t
t = Timer
For i = 1 To Sheets.Count
If Sheets(i).Name <> "总表" Then
   irow = Sheets(i).[a65536].End(xlUp).Row
   icolumn1 = Sheets(i).[iv2].End(xlToLeft).Column
   icolumn2 = Sheets(i).[iv3].End(xlToLeft).Column
   icolumn = WorksheetFunction.Max(icolumn1, icolumn2)
   Sheets(i).Cells(7, 2 + icolumn).Resize(100, 15).ClearContents
   tepar = Sheets(i).[a1].Resize(irow, icolumn)
   ReDim ar(1 To irow, 1 To icolumn)
   
   If irow = 4 Then
       Sheets(i).Cells(1, 1).Resize(4, icolumn).Copy Sheets(i).Cells(4, 2 + icolumn)
    End If
   
    If irow >= 5 Then
      Sheets(i).Cells(1, 1).Resize(3, icolumn).Copy Sheets(i).Cells(4, 2 + icolumn)
       For k = 1 To icolumn
         ar(1, k) = tepar(4, k)
        Next
      m = 1
      For q = 5 To irow
        g1 = WorksheetFunction.CountIfs(Sheets(i).Cells(q - 1, 1).Resize(1, icolumn), ">0")
        g2 = WorksheetFunction.CountIfs(Sheets(i).Cells(q, 1).Resize(1, icolumn), ">0")
        g3 = WorksheetFunction.CountIfs(Sheets(i).Cells(q - 1, 1).Resize(1, 7), ">0")
        g4 = WorksheetFunction.CountIfs(Sheets(i).Cells(q, 1).Resize(1, 7), ">0")
        g5 = WorksheetFunction.CountIfs(Sheets(i).Cells(q - 1, 1).Resize(1, 8), ">0")
        g6 = WorksheetFunction.CountIfs(Sheets(i).Cells(q, 1).Resize(1, 8), ">0")
       If tepar(q - 1, 3) = tepar(q, 1) And g1 = g2 And g3 = g4 And g5 = g6 Then
          ar(m, 3) = tepar(q, 3)
            For k = 7 To icolumn
              ar(m, k) = ar(m, k) + tepar(q, k)
            Next
          Else
            m = m + 1
            For k = 1 To icolumn
              ar(m, k) = tepar(q, k)
            Next
       End If
     Next
     Sheets(i).Cells(7, 2 + icolumn).Resize(m, icolumn) = ar
    End If

wwdfefgg

翁知江安 发表于 2024-12-13 21:24
Sub hz1213()
Dim i, j, k, m, p, q, g1, g2, g3, g4, g5, g6, irow, irow1, icolumn, icolumn1, icolumn2 ...

提示出错。。。。。。。。。。。。

wwdfefgg

shiruiqiang 发表于 2024-12-13 09:50
自己改一下吧。既能汇总，也能分表汇总

麻烦加上表头，，把 表几  那列删除了，，合并后的数值保留2位小数把，，其他都挺好的

shiruiqiang

你表头有了，运行代码只能一次。
否则后续一直扩列了

wwdfefgg

shiruiqiang 发表于 2024-12-14 15:04
你表头有了，运行代码只能一次。
否则后续一直扩列了

哦，要是能加上表头就完美了

wwdfefgg

shiruiqiang 发表于 2024-12-13 09:50
自己改一下吧。既能汇总，也能分表汇总

麻烦看看这个表，，合并的时候，提示出错


2024-12-15.rar (69.84 KB, 下载次数: 3)

2024-12-15 08:59 上传

点击文件名下载附件

shiruiqiang

shiruiqiang

wwdfefgg

shiruiqiang 发表于 2024-12-15 09:07

   For Each sht In Sheets
    If sht.Name <> "计算表" Then


把这个删除就行了，，运行不了

初学VBA，麻烦发个完整代码，，我测试一下

wwdfefgg

求高手解决。。。。。。。。。。。。。。。。