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

wwdfefgg · 发表于 2024-12-11 08:17

本帖最后由 wwdfefgg 于 2024-12-11 08:18 编辑

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

在表1和表2 中我做了示例

比如下面我框选的这些，A列到C列段落连续,后面有数的单元格所在的列都相同，就可以合并到一起，
单元格数值为0或为空的，一律按空处理

参考程序可以用，但每次要一个表一个表的把数据复制过去，运行完毕后，又要复制回来，，比较麻烦。

请参照参考程序，在总表里面做一个按钮，，一键就可以对表1到表6的数据进行合并

每天要处理的数据不同，如果哪个表里没有数据，可以跳过，不用合并。。如果没有满足合并条件的，也可以跳过。

Desktop.rar (96.19 KB, 下载次数: 13)

wwdfefgg · 发表于 2024-12-11 16:33

顶起来啊....

shiruiqiang · 发表于 2024-12-11 18:09

本帖最后由 shiruiqiang 于 2024-12-11 18:57 编辑

================

shiruiqiang · 发表于 2024-12-11 18:43

本帖最后由 shiruiqiang 于 2024-12-11 18:57 编辑

======================

wwdfefgg · 发表于 2024-12-12 04:31

shiruiqiang 发表于 2024-12-11 18:43
======================

顶起来。。。。。

wwdfefgg · 发表于 2024-12-12 16:18

顶起来。。。。。

chxw68 · 发表于 2024-12-12 17:27

Sub test()
Dim r%, i%, m%
Dim arr, brr, zrr()
Dim xm$
Dim d As Object
Set d = CreateObject("scripting.dictionary")
With Worksheets("表1")
r = .Cells(.Rows.Count, 1).End(xlUp).Row
arr = .Range("a4:j" & r)
ReDim brr(1 To UBound(arr), 1 To 1)
For i = 1 To UBound(arr)
For j = 7 To 10
brr(i, 1) = brr(i, 1) & IIf(Len(arr(i, j)) = 0 Or arr(i, j) = 0, "0", "1")
Next
Next
xm = Empty
s = 0
m = 0
For i = 1 To UBound(brr)
If brr(i, 1) <> xm Or arr(i, 1) <> s Then
m = m + 1
ReDim Preserve zrr(1 To m)
zrr(m) = Array(i, i)
Else
If m > 0 Then
zrr(m)(1) = i
End If
End If
xm = brr(i, 1)
s = arr(i, 3)
Next
ReDim crr(1 To UBound(zrr), 1 To UBound(arr, 2))
For k = 1 To UBound(zrr)
crr(k, 1) = arr(zrr(k)(0), 1)
crr(k, 2) = arr(zrr(k)(0), 2)
crr(k, 3) = arr(zrr(k)(1), 3)
For j = 7 To 10
For i = zrr(k)(0) To zrr(k)(1)
crr(k, j) = crr(k, j) + arr(i, j)
Next
Next
Next
.Range("w4").Resize(UBound(crr), UBound(crr, 2)) = crr
End With
End Sub

复制代码

chxw68 · 发表于 2024-12-12 17:27

只写了表1的代码。

usedrange · 发表于 2024-12-12 19:02

只有第一个表有规律，第二个表看不懂了
只做第一个表

Sub tt()
Dim ar, br, i%, j%, r%, c%, n%, m%, rr%
For Each sh In Sheets
If sh.Name <> "总表" Then
With Sheets(sh.Name)
r = .UsedRange.Rows.Count
c = .UsedRange.Columns.Count
ReDim br(1 To 100, 1 To c - 6)
If r > 3 Then
ar = .[a4].Resize(r - 3, c): rr = 1: m = 0
For i = 1 To UBound(ar)
n = 0
For j = 7 To c
If ar(i, j) <> 0 Then
n = n + j
End If
Next j
If i = 1 Then s = ar(i, 1) & ar(i, 2): m = n
If n <> m Then
s = s & ar(i - 1, 3): s = ar(i, 1) & ar(i, 2): m = n: rr = rr + 1
End If
For j = 7 To c
If ar(i, j) <> 0 Then
br(rr, j - 6) = br(rr, j - 6) + Round(ar(i, j), 2)
End If
Next j
If i = UBound(ar) Then s = s & ar(i, 3)
Next i
End If
.Cells(4, c + 2).Resize(UBound(br), UBound(br, 2)) = br
End With
Exit For
End If
Next sh
End Sub

复制代码

shiruiqiang · 发表于 2024-12-12 19:25

本帖最后由 shiruiqiang 于 2024-12-12 19:44 编辑

11楼重新写了一个

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

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