求更好办法串联字符

票留记 · 发表于 2020-2-20 15:12

目前自己掌握的办法，是用&一个一个串。用起来耗时又容易出错。求大神指点指点，如何更好的将明细的工作内容汇总一起。谢谢。

工作1.zip (8.61 KB, 下载次数: 31)

lsdongjh · 发表于 2020-2-20 15:44

当一回苦力：

Sub Test()
Dim sh As Worksheet, lngRow As Long, lngCol As Long
Dim lngStart As Long, lngEnd As Long, arrTemp As Variant, strTemp As String
Dim arrString() As String, arrResult As Variant
Set sh = Sheets("Sheet1")
lngStart = 2: lngEnd = 5
'取得拼装字符,数量用@@代替
arrTemp = sh.Range("A" & lngStart & ":C" & lngEnd)
ReDim arrString(LBound(arrTemp) To UBound(arrTemp))
For lngRow = LBound(arrTemp) To UBound(arrTemp)
arrString(lngRow) = arrTemp(lngRow, 1) & arrTemp(lngRow, 2) & "@@" & arrTemp(lngRow, 3)
Next
'取得数量
arrTemp = sh.Range("E" & lngStart & ":G" & lngEnd)
ReDim arrResult(1 To 1, LBound(arrTemp, 2) To UBound(arrTemp, 2)) As String
For lngCol = LBound(arrTemp, 2) To UBound(arrTemp, 2)
strTemp = ""
For lngRow = LBound(arrTemp) To UBound(arrTemp)
If Val(arrTemp(lngRow, lngCol)) <> 0 Then
strTemp = strTemp & ";" & Replace(arrString(lngRow), "@@", arrTemp(lngRow, lngCol))
End If
arrResult(1, lngCol) = Mid(strTemp, 2)
Next
Next
sh.Range("E7").Resize(1, UBound(arrResult, 2)) = arrResult
End Sub

复制代码

票留记 · 发表于 2020-2-20 15:44

分为两张表，用函数CONCAT可暂缓解决。麻烦各位大神帮忙帮忙。谢谢。

AI_ACE · 发表于 2020-2-20 15:53

本帖最后由 AI_ACE 于 2020-2-20 15:54 编辑

CONCAT 函数，图片是先连接一行然后再用另一个CONCAT连接所有结果。
也可以调整好你的数据顺序，来使CONCAT函数连接一个矩形区域，函数将会从左到右从上到下的顺序连接所有所选范围内格子的文字。

1588078/37 · 发表于 2020-2-20 15:58

Sub 汇总()
Set d = CreateObject("Scripting.Dictionary")
x = Range("A65536").End(xlUp).Row
y = ActiveSheet.UsedRange.Columns.Count
arr = Range(Cells(1, 1), Cells(x, y))
For i = 3 To x - 2
For j = 5 To y
If arr(i, j) > 0 Then
d(j) = d(j) & "；" & arr(i, 1) & arr(i, 2) & arr(i, j) & arr(i, 3)
End If
arr(x - 1, j) = Mid(d(j), 2)
arr(x, j) = arr(x, j) + arr(i, 4) * arr(i, j)
Next
Next
Cells(1, 1).Resize(x, y) = arr
End Sub

复制代码

3190496160 · 发表于 2020-2-20 16:05

Sub test()
With Sheet1
ws = .Cells(Rows.Count, 1).End(xlUp).Row
.Range(.Cells(ws - 1, 5), .Cells(ws, 7)) = Empty
ar = .Range("a1:g" & ws)
For j = 5 To UBound(ar, 2)
      m = "": hj = 0
      For i = 3 To UBound(ar) - 2
         If Trim(ar(i, j)) <> "" Then
            If m = "" Then
                  m = ar(i, 1) & ar(i, 2) & ar(i, j) & ar(i, 3)
            Else
                  m = m & "；" & ar(i, 1) & ar(i, 2) & ar(i, j) & ar(i, 3)
            End If
            hj = hj + ar(i, 4) * ar(i, j)
         End If
      Next i
      ar(UBound(ar) - 1, j) = m
      ar(UBound(ar), j) = hj
Next j
.Range("a1:g" & ws) = ar
End With
End Sub

3190496160 · 发表于 2020-2-20 16:07

工作1.rar (16.29 KB, 下载次数: 0)

1588078/37 · 发表于 2020-2-20 16:08

Sub 汇总()
Set d = CreateObject("Scripting.Dictionary")
x = Range("A65536").End(xlUp).Row
y = ActiveSheet.UsedRange.Columns.Count
arr = Range(Cells(1, 1), Cells(x, y))
For j = 5 To y
For i = 3 To x - 2
If arr(i, j) > 0 Then
d(j) = d(j) & "；" & arr(i, 1) & arr(i, 2) & arr(i, j) & arr(i, 3)
End If
arr(x - 1, j) = Mid(d(j), 2)
arr(x, j) = arr(x, j) + arr(i, 4) * arr(i, j)
Next
Next
Cells(1, 1).Resize(x, y) = arr
End Sub
改下，省点时间，循环顺序弄反

复制代码

1588078/37 · 发表于 2020-2-20 16:10

本帖最后由 1588078/37 于 2020-2-20 16:13 编辑

arr(x - 1, j) 要先置0下，
Sub 汇总()
Set d = CreateObject("Scripting.Dictionary")
x = Range("A65536").End(xlUp).Row
y = ActiveSheet.UsedRange.Columns.Count
arr = Range(Cells(1, 1), Cells(x, y))

For j = 5 To y
arr(x, j) = 0
For i = 3 To x - 2
If arr(i, j) > 0 Then
d(j) = d(j) & "；" & arr(i, 1) & arr(i, 2) & arr(i, j) & arr(i, 3)
End If
arr(x - 1, j) = Mid(d(j), 2)
arr(x, j) = arr(x, j) + arr(i, 4) * arr(i, j)
Next
Next
Cells(1, 1).Resize(x, y) = arr

End Sub

网海遨游 · 发表于 2020-2-20 16:18

楼主,这样操作行不行?

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

[求助] 求更好办法串联字符

评分

评分