以整列单元格查找其它工作薄并修改所在位置对应位置的内容

zhurq9876 · 发表于 2019-3-15 12:19

本帖最后由 zhurq9876 于 2019-3-17 11:08 编辑

微信图片_20190315121130.png

比如以"中继段表格"中AP7单元格字符 "光纤标号 : 026" , 查找“福泉居委会旁新光配-幸福新村10幢(1-12)芯”、“福泉居委会旁新光配-幸福新村10幢接头点封存(13-48)芯”这两个工作薄中"中继段"工作表A列中字符为“光纤标号 : 026”的单元格，并把AP7后面的几个数字写入对应的几个位置(写入表的几个位置都是相对固定的)

zhurq9876 · 发表于 2019-3-15 14:48

不知道有没有热心坛友伸出援手

zhurq9876 · 发表于 2019-3-17 08:13

不知道有没有热心坛友伸出援手

蓝桥玄霜 · 发表于 2019-3-17 11:45

请见代码。

zhurq9876 · 发表于 2019-3-17 15:17

本帖最后由 zhurq9876 于 2019-3-17 19:10 编辑

蓝桥玄霜发表于 2019-3-17 11:45
请见代码。

谢谢蓝版，有提示下标越界

Sub lqxs()
Dim d, arr, i&, mypath$, myname$, j&, aa, bb
Set d = CreateObject("scripting.dictionary")
Application.ScreenUpdating = False
Sheet1.Activate
arr = [aj13:at29]
For j = 1 To UBound(arr, 2) Step 6
For i = 1 To UBound(arr)
If arr(i, j) <> "" Then
aa = Split(arr(i, j), ";")
d(Trim(aa(1))) = arr(i, j + 1) & "," & arr(i, j + 2) & "," & arr(i, j + 3) & "," & arr(i, j + 4)
End If
Next
Next
mypath = ThisWorkbook.Path & ""
myname = Dir(mypath & "*.xls")
Do While myname <> ""
If InStr(myname, "居委会") Then
With GetObject(mypath & myname)
arr = .Sheets("中继段").UsedRange
With .Sheets("中继段")
For i = 1 To UBound(arr)
If InStr(arr(i, 1), "光纤标号") Then
aa = Split(arr(i, 1), ":")
If d.exists(Trim(aa(1))) Then
bb = Split(d(Trim(aa(1))), ",")
.Cells(i + 16, 8) = bb(0): .Cells(i + 16, 17) = bb(1)
.Cells(i + 20, 8) = bb(2): .Cells(i + 20, 9) = bb(3)
End If
End If
Next
End With
.Close True
End With
End If
myname = Dir
Loop
MsgBox "ok"
Application.ScreenUpdating = True
End Sub

复制代码

zhurq9876 · 发表于 2019-3-17 15:26

蓝桥玄霜发表于 2019-3-17 11:45
请见代码。

谢谢蓝版，运行提示下标越界微信截图_20190317151647.png

Sub lqxs()
Dim d, arr, i&, mypath$, myname$, j&, aa, bb
Set d = CreateObject("scripting.dictionary")
Application.ScreenUpdating = False
Sheet1.Activate
arr = [aj1:at299]
For j = 1 To UBound(arr, 2) Step 6
For i = 1 To UBound(arr)
If arr(i, j) <> "" Then
aa = Split(arr(i, j), ";")
d(Trim(aa(1))) = arr(i, j + 1) & "," & arr(i, j + 2) & "," & arr(i, j + 3) & "," & arr(i, j + 4)
End If
Next
Next
mypath = ThisWorkbook.Path & ""
myname = Dir(mypath & "*.xls")
Do While myname <> ""
If InStr(myname, "居委会") Then
With GetObject(mypath & myname)
arr = .Sheets("中继段").UsedRange
With .Sheets("中继段")
For i = 1 To UBound(arr)
If InStr(arr(i, 1), "光纤标号") Then
aa = Split(arr(i, 1), ":")
If d.exists(Trim(aa(1))) Then
bb = Split(d(Trim(aa(1))), ",")
.Cells(i + 16, 8) = bb(0): .Cells(i + 16, 17) = bb(1)
.Cells(i + 20, 8) = bb(2): .Cells(i + 20, 9) = bb(3)
End If
End If
Next
End With
.Close True
End With
End If
myname = Dir
Loop
MsgBox "ok"
Application.ScreenUpdating = True
End Sub

复制代码

蓝桥玄霜 · 发表于 2019-3-18 08:45

第10行aa = Split(arr(i, j), ";")
应为
aa = Split(arr(i, j), ":")

zhurq9876 · 发表于 2019-3-18 09:17

蓝桥玄霜发表于 2019-3-18 08:45
第10行aa = Split(arr(i, j), ";")
应为
aa = Split(arr(i, j), ":")

非常感谢，再问个问题，执行代码以后，EXCEL文件无法打开了。被写入的那两个文件

zhurq9876 · 发表于 2019-3-18 09:46

好像被隐藏起来了

zhurq9876 · 发表于 2019-3-18 10:07

加句 Windows(.Name).Visible = True 可以了

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

[求助] 以整列单元格查找其它工作薄并修改所在位置对应位置的内容