VBA范围内多列内各自配对 ( 有难度 )

On_fire

VBA范围内多列内各自配对 ( 有难度 )

*

Sheet2是源数据 ( 父页 ), A~N列是固定给的,

1~8行标题行不参加配对, 往下的行数及资料是变量,

单元格[C9]列往右往下,

除数值之外是”关键词/唯一值”, 每列单元格的上一行的A列是对应值( 添加值 )

*

Sheet1及Sheet 2是相同的数据结构

除了数值外, 每列的关键词要去掉后缀( 如:符号, 数字 ), 及做关连的配对

*

代码的逻辑如下,

Sheet1的C~N列, 左到右, 一列又一列( C列对C列 ),

每一列单元格如不为空,

同时, 关键词如配对上, 需要” 添加对应值为前缀 及 添加点号 “

*

部分模拟结果在Sheet1(2)

*

这题有点绕, 难度高!

恳请大神, 老师帮忙…谢谢!

liulang0808

楼主发了很多问题，大部分的难度在于如何理解楼主的描述信息？
建议楼主结合附件，用通俗易懂的语言逐步举例描述
这样便于大家理解

fanyoulin

我仔细看了下，还没完全看懂，大概能知道一点点，有两个问题：
1、数据结构很诡异，那么多列但又只有2行，为何不转置为两列多行？
2、如果是两列多行的结构，用vlookvp找一下，如果找到再用函数组合一下文本信息我感觉就差不多了；
数据结构合理的话，我感觉就是个简单问题，但楼主这结构还真不好搞。

On_fire

liulang0808 发表于 2023-5-30 13:11
楼主发了很多问题，大部分的难度在于如何理解楼主的描述信息？
建议楼主结合附件，用通俗易懂的语言逐步举 ...

版主好,
以前有发过相似的难题, 褚老师给了答案在下帖, 代码的思路在10楼,  
https://club.excelhome.net/thread-1657960-1-1.html
但是, 现在的新要求是改为两页( Sheet1及Sheet2的列列配对) ,
如C列对C列, D列对D列, 如类推…

On_fire

fanyoulin 发表于 2023-5-30 14:08
我仔细看了下，还没完全看懂，大概能知道一点点，有两个问题：
1、数据结构很诡异，那么多列但又只有2行， ...

是的, 这题是有点绕…

fzxba

1. Sub test0()
   
2.   Dim ar, i As Long, j As Long
   
3.   Dim Dict() As Object, s As String, k
   
4.   
   
5.   With Sheet2
   
6.     ar = .Range("A1:N" & .UsedRange.Find("*", , -4163, , 1, 2).Row)
   
7.   End With
   
8.   ReDim Dict(3 To UBound(ar, 2))
   
9.   For j = 3 To UBound(ar, 2)
   
10.     Set Dict(j) = CreateObject("Scripting.Dictionary")
    
11.     For i = 9 To UBound(ar)
    
12.       s = Trim(ar(i, j))
    
13.       If Len(s) Then
    
14.         If Val(s) = 0 Then Dict(j).Add s, ar(i - 1, 1)
    
15.       End If
    
16.     Next
    
17.   Next
    
18.   
    
19.   With Sheet1
    
20.     ar = .Range("A1:N" & .UsedRange.Find("*", , -4163, , 1, 2).Row)
    
21.   End With
    
22.   For j = 3 To UBound(ar, 2)
    
23.     For i = 9 To UBound(ar)
    
24.       s = Trim(ar(i, j))
    
25.       If Len(s) Then
    
26.         If Val(s) = 0 Then
    
27.           For Each k In Dict(j).Keys
    
28.             If InStr(s, k) Then
    
29.               ar(i, j) = Dict(j)(k) & ". " & ar(i, j)
    
30.               Exit For
    
31.             End If
    
32.           Next
    
33.         End If
    
34.       End If
    
35.     Next
    
36.     Set Dict(j) = Nothing
    
37.   Next
    
38.   
    
39.   Sheet3.Range("A1").Resize(UBound(ar), UBound(ar, 2)) = ar
    
40.   Beep
    
41. End Sub

复制代码

On_fire

fzxba 发表于 2023-5-30 16:04

大神, 厉害!
好久没见啦, 感谢您出手帮忙…

hl19881005

路过看看，学习一下！