[求助]如何把Word 单元格中的内容批量移位

Bands

在此向各位高手请教，帮忙解决一个难题：
如WORD文档中有多个表格，而在最后一个表格中, 从第一个单元格开始的连续若干格中，各有一张图片；而在次行的单元格中则有相对应的图片内容描述。

现在的问题是：当有时想在某处（第一张之后，最后一张图片之前）插入一张新的图片及其对应的描述时，需对欲插入点之后的每一对图片和描述进行多次“复制/粘贴”操作来进行移位，相应地，如果要删除某一张时，需要把其后的全部向前移动。如果图片张数多时（60多张）工作量非常大。

请问有无何种快速的方法可行（例如通过VBA或者宏）？
注： 此表格列数固定为3列, 有图片的单元格须连续，而行数根据图片数不定。
附情请参见所附WORD文档。

请各位高手不吝赐教，谢谢！

qZF0hGax.rar (185.4 KB, 下载次数: 11)

2005-12-4 18:06 上传

点击文件名下载附件
[求助]如何把Word 单元格中的内容批量移位

[此贴子已经被作者于2005-12-4 18:13:12编辑过]

c81

只将字和其对应的图片同时拖黑，再拖到目的地不行吗？

同时多选中几组也是可以移动嘀。

[此贴子已经被作者于2005-12-4 20:32:41编辑过]

菊石泽露

vba如何实现呢？版主有办法吗？

守柔

QUOTE:

以下是引用菊石泽露在2007-3-9 22:31:15的发言：
vba如何实现呢？版主有办法吗？

请参考：

http://club.excelhome.net/viewthread.php?tid=152717&px=0

我提示一下，用WORD特有的方法，即将图片链接到文件，这是一个域，将域读取到数组，再赋值到单元格即可。

sylun

不会处理图片对象，只用移动单元格的方法试学着做了一个前移图片的宏，好像可以执行，至于运行速度等就无力考究了，请各位赐教。

Sub movepics()
'请首先将光标置于第一个需要前移图片的（空白）单元格。
On Error GoTo exit_1
Application.ScreenUpdating = False
Dim n As Integer, Rownum As Integer, Colnum As Byte
NP:  With Selection
        '判断光标是否在表格中
        If .Information(wdWithInTable) Then
            '要求插入点所在表格为3列且大于3行，并只选中一个单元格
            If .Tables(1).Rows.Count > 3 _
            And .Tables(1).Columns.Count = 3 And .Cells.Count = 1 Then
                Rownum = .Information(wdEndOfRangeRowNumber)
                Colnum = .Information(wdEndOfRangeColumnNumber)
                '判断插入点是否在表格最后两行，此处可能有误。
                If Rownum + 1 >= .Tables(1).Rows.Count And Colnum = 3 Then
                    Application.ScreenUpdating = True
                    MsgBox "已到表格末尾，共移动了" & n & "次。", vbOKOnly
                    Exit Sub
                End If
                '判断插入点是否处于表格第3列
                If Colnum Mod 3 <> 0 Then
                    .MoveRight unit:=wdCell, Count:=1
                    .MoveDown unit:=wdLine, Count:=1, Extend:=wdExtend
                    .Cut
                    .MoveLeft unit:=wdCell, Count:=1
                    .MoveDown unit:=wdLine, Count:=1, Extend:=wdExtend
                    .Paste
                    .MoveRight unit:=wdCell, Count:=2
                Else
                    .MoveDown unit:=wdLine, Count:=2
                    .MoveLeft unit:=wdCell, Count:=2
                    .MoveDown unit:=wdLine, Count:=1, Extend:=wdExtend
                    .Cut
                    .MoveUp unit:=wdLine, Count:=2
                    .MoveRight unit:=wdCell, Count:=2
                    .MoveDown unit:=wdLine, Count:=1, Extend:=wdExtend
                    .Paste
                    .MoveDown unit:=wdLine, Count:=1
                    .MoveLeft unit:=wdCell, Count:=2
                End If
                n = n + 1
                GoTo NP
            End If
        End If
    End With
exit_1: MsgBox "插入点或格式有误！", vbCritical
End Sub

sylun

也尝试用range对象练习做了一个，请各位指点

Sub movepics2()
'请先将插入点置于第一个需要前移图片的（空白）单元格。
On Error goto exit_1
Application.ScreenUpdating = False
Dim n As Integer, Rownum As Integer, Colnum As Byte, myrange As Range
    '如果插入点位于表格内，且表格大于3行，则将该表格中插入点及其后的所有单元格设置为处理区域
    With Selection
        If .Information(wdWithInTable) Then
            If .Tables(1).Rows.Count > 3 And .Cells.Count = 1 Then
                Rownum = .Information(wdEndOfRangeRowNumber)
                Colnum = .Information(wdEndOfRangeColumnNumber)
                .MoveRight unit:=wdCharacter, Count:=.Tables(1).Columns.Count _
                    - Colnum + 1, Extend:=wdExtend
                .MoveDown unit:=wdLine, Count:=.Tables(1).Rows.Count _
                    - Rownum, Extend:=wdExtend
            End If
        End If
        Set myrange = .Range
    End With
    With myrange
    '在单数行的单元格中循环处理
    For i = 1 To .Cells.Count
        If .Cells(i).RowIndex Mod 2 = 1 Then
            '如果单元格位于最右列
            If .Cells(i).ColumnIndex = .Tables(1).Columns.Count And _
                .Cells(i).RowIndex + 1 < .Tables(1).Rows.Count Then
                '前移图片
                With myrange.Cells(i + .Tables(1).Columns.Count + 1).Range
                    .Select
                    .Cut
                End With
                .Cells(i).Range.Paste
                '前移图片说明文字
                With myrange.Cells(i + .Tables(1).Columns.Count * 2 + 1).Range
                    .Select
                    .Cut
                End With
                .Cells(i + .Tables(1).Columns.Count).Range.Paste
            '如果到达最后一个单元格（表格最后一行应完整）
            ElseIf .Cells(i).RowIndex + 1 >= .Tables(1).Rows.Count _
            And .Cells(i).ColumnIndex = 3 Then
                Application.ScreenUpdating = True
                MsgBox "已到表格末尾，共前移了" & n & "次。"
                Exit Sub
            '其他情况下
            Else
                '前移图片
                With myrange.Cells(i + 1).Range
                    .Select
                    .Cut
                End With
                .Cells(i).Range.Paste
                '前移说明文字
                With myrange.Cells(i + .Tables(1).Columns.Count + 1).Range
                    .Select
                    .Cut
                End With
                .Cells(i + .Tables(1).Columns.Count).Range.Paste
            End If
            n = n + 1
        End If
    Next i
    End With
exit_1: Application.ScreenUpdating = True
        MsgBox "操作或格式有误！", vbCritical
End Sub