پر کردن سلول های جدول با ماکرو

Question

همانطور که با جداول در Word کار می کنید، ممکن است بخواهید سلول های مختلف یک جدول را با مقدار تنظیم شده پر کنید. به عنوان مثال، ممکن است بخواهید چیزی را در کلیپ بورد کپی کنید و سپس محتویات کلیپ بورد را در هر سلول جدول بچسبانید. ماکرو زیر این کار را انجام می دهد:

Sub PasteToCells()
    Dim TargetRange As Range
    Dim oTargCell As Cell

    If Selection.Cells.Count = 0 Then
        "Quit if no cells in selection
        MsgBox "No cells selected", vbCritical
        Exit Sub
    End If
    On Error Resume Next
    Set TargetRange = Selection.Range
    For Each oTargCell In Selection.Cells
        oTargCell.Range.Paste
    Next oTargCell
    TargetRange.Select
End Sub

ماکرو با بررسی برای اطمینان از اینکه انتخاب شامل تعدادی سلول است شروع می شود. اگر نه، کاربر مطلع می شود و ماکرو به پایان می رسد. سپس انتخاب در یک متغیر ذخیره می شود تا بتوان آن را (دوباره) در انتهای ماکرو انتخاب کرد. بدون این کد، ماکرو نقطه درج را در خانه اول انتخاب اصلی جمع می‌کند.

گوشت واقعی ماکرو در حلقه For ... بعدی است. از سلول‌های انتخابی عبور می‌کند و هر چیزی را که وجود دارد با محتوای کلیپ بورد جایگزین می‌کند. در نهایت، انتخاب اصلی دوباره انتخاب می شود و ماکرو به پایان می رسد.

احتمالاً متوجه شده اید که عبارت On Error در ماکرو نیز وجود دارد. این عبارت اساساً به Word می گوید که هر گونه خطا را نادیده بگیرد و با عبارت بعدی ادامه دهد. خطاهایی که ممکن است ایجاد شوند عبارتند از اجرای ماکرو بدون هیچ چیز در کلیپ بورد یا تلاش برای چسباندن جدول در سلول جدول. Word هیچ کدام از کارها را انجام نمی دهد، اما تا زمانی که با تمام سلول های انتخابی تمام شود به تلاش ادامه می دهد.

باید توجه داشته باشید که این ماکرو هر چیزی را که در سلول های انتخاب شده است با محتوای کلیپ بورد جایگزین می کند. هر آنچه قبلاً در سلول ها بود از بین می رود. اگر می‌خواهید به جای آن اطلاعاتی را به ابتدای سلول‌ها اضافه کنید، بدون اینکه محتوای موجود سلول را مختل کنید، می‌توانید از این ماکرو کمی تغییر یافته استفاده کنید:

Sub PasteToCellsStart()
    Dim TargetRange As Range
    Dim oTargCell As Cell
    Dim PasteRange As Range

    If Selection.Cells.Count = 0 Then
        "Quit if no cells in selection
        MsgBox "No cells selected", vbCritical
        Exit Sub
    End If
    On Error Resume Next
    Set TargetRange = Selection.Range
    For Each oTargCell In Selection.Cells
        Set PasteRange = oTargCell.Range
        PasteRange.Collapse wdCollapseStart
        PasteRange.Paste
    Next oTargCell
    TargetRange.Select
End Sub

یکی از آخرین اصلاحات ارائه یک ماکرو است که در انتهای سلول ها قرار می گیرد. ممکن است فکر کنید که می‌توانید wdCollapseStart را با wdCollapseEnd در ماکرو قبلی جایگزین کنید، اما در جدول‌ها به درستی کار نمی‌کند. در عوض، باید حلقه For... Next را در ماکرو بالا جایگزین کنید. مثال زیر یک نسخه تغییر یافته از آن را نشان می‌دهد. ماکرو

Sub PasteToCellsEnd()
    Dim TargetRange As Range
    Dim oTargCell As Cell
    Dim PasteRange As Range

    If Selection.Cells.Count = 0 Then
        "Quit if no cells in selection
        MsgBox "No cells selected", vbCritical
        Exit Sub
    End If
    On Error Resume Next
    Set TargetRange = Selection.Range
    For Each oTargCell In Selection.Cells
        Set PasteRange = oTargCell.Range.Characters.Last
        PasteRange.Collapse wdCollapseStart
        PasteRange.Paste
    Next oTargCell
    TargetRange.Select
End Sub