相同条件的数据，自动补充字段前缀

风的承诺　发表于：2019-08-14 19:25:02 　

复制

点击下载此附件

原始数

说明：123456789/123/456/789 表示为：后三位不相同，前面的前缀相同

99999987456/0000/1111/2222 表示为：后三位不相同，前面的前缀相同

需要将数据进行分割并被充前缀

下图为我目前只能完成到数据分割，前缀相同的自动补充！

完成的效果如下：

希望老师和各位高手能帮忙处理指导一下，感谢！

如果这样完成了，那么反过来，如何实现？？将图三的转换结果，还原成图一的初始结果？

一个是相同的分割加前缀补充

一个是相同的进行合并，相同部份前缀删除，不同的尾数以“/”隔开！！！

麻烦各位高手帮忙修改一下附档代码，谢谢

Top

风的承诺发表于：2019-08-15 08:18:22

现在遇到的问题是分割后，料号相同的前缀不能自动复制填充！请高手和老师们帮帮忙，先谢谢了！

“/”后面有几位表示尾缀有几位不同！以此为规律！

1.料号相同的前缀不能自动复制填充！

2.再将图3的效果反过来达到图一的效果！

帮忙修改一下代码！谢谢各位老师和搞手们了！

Top

西出阳关无故人发表于：2019-08-15 08:40:17

1、附件下载“失败-未发现文件”是什么原因？

2、99999987456/0000/1111/2222 表示为：后三位不相同，前面的前缀相同 -----这是后三位不相同吗？我看是后四位不相同啊？

如果确实都是后三位不同，或者后N位不同，但是有标记、或规律可循，应该不难。

Top

风的承诺发表于：2019-08-15 09:27:18

有三位和四位不相同的，可以做成这种思路， /后面的有几位表示就是后面的几位数不相同

我重新上传附件点击下载此附件

我这里可以下载附件！

Top

风的承诺发表于：2019-08-15 09:33:29

不好意思，有三位和四位不相同的，可以做成这种思路，“/”后面的有几位表示就是后面的几位数不相同

重新上传最新附件：点击下载此附件

Top

风的承诺发表于：2019-08-15 09:35:06

Top

西出阳关无故人发表于：2019-08-15 10:34:13

这是分解的：

Private Sub Command0_Click()

On Error Resume Next
Dim A() As String
Dim i As Integer
Dim Rst As ADODB.Recordset
Dim rstTmp As ADODB.Recordset
Dim qz '前缀
Set Rst = New ADODB.Recordset
Set rstTmp = New ADODB.Recordset

Rst.Open "BOM", CurrentProject.Connection, 2, 3
rstTmp.Open "BOM1", CurrentProject.Connection, 2, 3

Do Until Rst.EOF
A = Split(Rst![料号], "/")
qz = Mid(A(0), 1, Len(A(0)) - Len(A(UBound(A)))) '设置前缀
For i = LBound(A) To UBound(A)
rstTmp.AddNew
rstTmp![规格] = Rst![规格]
rstTmp![位置] = Rst![位置]
rstTmp![料号] = IIf(i > 0, qz & A(i), A(i)) '根据记录的位置决定是否添加前缀
Next i
Rst.MoveNext
Loop
rstTmp.Update
Rst.Close
rstTmp.Close
Set Rst = Nothing
Set rstTmp = Nothing
MsgBox "数据追加成功！"
DoCmd.OpenTable "BOM1"

End Sub

至于还原就需要规定如何还原，固定位数的尾数？还是根据什么条件决定尾数的位数？

Top

风的承诺发表于：2019-08-15 10:50:14

上面的代码报错：

规律：

1.规格列相同

2.料号前缀相同，尾缀3位、4位、5位不同的或N位不同的，合并到一起，不同的尾缀以“/”分开

料号规格

例 99999987456 1R

99999980000 1R

99999981111 1R

99999982222 1R

料号规格

还原成 99999987456/0000/1111/2222 1R

Top

西出阳关无故人发表于：2019-08-15 11:02:14

报错是你的引用有问题。

Top

风的承诺发表于：2019-08-15 11:33:17

我重新试了一下还是报错不行！

原来的代码可以正常运行，还请老师再帮忙看看，感谢

Top

西出阳关无故人发表于：2019-08-15 11:46:27

看看你的引用有没有丢失？

Top

风的承诺发表于：2019-08-15 11:50:41

没有发现有丢失

你那边可以运行吗？把你的附档上传我试一下看看，感谢

Top

风的承诺发表于：2019-08-15 11:59:41

己解决了，确认是引用错误，感谢老师，

Top

西出阳关无故人发表于：2019-08-15 12:28:22

还原的方法之一：

Private Sub Command1_Click()
Dim Rec As New ADODB.Recordset
Dim RecA As New ADODB.Recordset
Dim RecB As New ADODB.Recordset
Dim N
Dim i, j, k
Dim str, SQL
CurrentDb.Execute "DELETE * FROM BOM2" '清空还原的目的表
Rec.Open "select 规格,位置 from BOM1 group by 规格,位置", CurrentProject.Connection, adOpenStatic, adLockReadOnly '按照规格和位置进行还原
For i = 1 To Rec.RecordCount '根据不同的规格进行分布循环
N = Len(DLookup("料号", "BOM1", "规格='" & Rec.Fields(0) & "' and 位置='" & Rec.Fields(1) & "'")) '获得指定规格的料号的长度
For j = N To 1 Step -1 '根据料号长度进行检验相同部分的位数
SQL = "select MID(料号,1," & j & ") from BOM1 where 位置='" & Rec.Fields(1) & "' AND 规格='" & Rec.Fields(0) & "' GROUP BY MID(料号,1," & j & ")"
RecA.Open SQL, CurrentProject.Connection, adOpenStatic, adLockReadOnly
If RecA.RecordCount = 1 Then '只有记录数为1的时候，才证明是相同的前缀
'获取合并料号
RecB.Open "SELECT 料号 from bom1 where 规格='" & Rec.Fields(0) & "' AND 位置='" & Rec.Fields(1) & "'", CurrentProject.Connection, adOpenStatic, adLockReadOnly
str = ""
str = RecB.Fields("料号")
If RecB.RecordCount > 1 Then
RecB.MoveNext
For k = 2 To RecB.RecordCount
str = str & "/" & Right(RecB.Fields(0), N - j)
RecB.MoveNext
Next k
End If
CurrentDb.Execute "INSERT INTO BOM2(料号,规格,位置) VALUES('" & str & "','" & Rec.Fields(0) & "','" & Rec.Fields(1) & "')" '追加到还原的目的表
RecB.Close
RecA.Close
Exit For
End If
RecA.Close
Next j
Rec.MoveNext
Next i
DoCmd.OpenTable "BOM2" '打开还原目的表查看结果
End Sub

BOM2是与bom结构相同的表

Top

总记录：13篇页次：1/1 9 1 :

Access交流中心

相同条件的数据，自动补充字段前缀