asked on

Macro to move columns in Excel and delete unnecessary rows and paste results into Word file

We need to extract a table from a PDF document into Excel and clean it up by moving columns around and deleting unnecessary rows, and then paste the results into a new Word file. This task is done several times weekly, so we would like to create a macro to automate the task.

Details:

The number of columns in Excel, and their position in the table may vary, but the column headings that we need are always named the same.

The Excel table will always reside in Sheet2.

Macro steps;

Move Column called IDENT to right of Column called NAME

Move Column called TYPE to right of Column called IDENT

Move Column called LATITUDE to right of Column called TYPE

Move Column called LONGITUDE to right of Column called LATITUDE

Remove all remaining columns to right of LONGITUDE that contain data

Under Column B (NAME) find first row with "-" in cell, and delete this entire row and all subsequent entire rows to last row containing any data

Copy the table, and then paste `as text only`, into a new Word file

I have attached a sample of the Excel table pre-cleanup.

Thanks!
Andrea
EE_Table_Cleanup.xlsx

Shums Faruk

Hi Andrea,

Try below, it will save as word file with the name "WayPoint" in the same folder where you will save attached file:

Option Explicit
Sub ColumnAdjustments()
Dim Ws As Worksheet
Dim LRow As Long, LCol As Long, FRow As Long
Dim MyCol As Variant, ColIndex As Integer
Dim ColFound As Range, ColCounter As Integer, CopyRng As Range
Dim AppWord As New Word.Application
Dim WordDoc As Word.Document

Set Ws = Worksheets("Sheet2")
MyCol = Array("NUM", "NAME", "IDENT", "TYPE", "LATITUDE", "LONGITUDE")
ColCounter = 1
With Application
    .ScreenUpdating = False
    .DisplayStatusBar = True
    .StatusBar = "!!! Please Be Patient...Updating Records !!!"
    .EnableEvents = False
    .Calculation = xlManual
End With

For ColIndex = LBound(MyCol) To UBound(MyCol)
    Set ColFound = Ws.Rows("1:1").Find(MyCol(ColIndex), LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByColumns, SearchDirection:=xlNext, MatchCase:=False)
    If Not ColFound Is Nothing Then
        If ColFound.Column <> ColCounter Then
            ColFound.EntireColumn.Cut
            Ws.Columns(ColCounter).Insert Shift:=xlToRight
            Application.CutCopyMode = False
        End If
        ColCounter = ColCounter + 1
    End If
Next ColIndex
LRow = Ws.Range("A" & Rows.Count).End(xlUp).Row
LCol = Ws.Cells(1, Columns.Count).End(xlToLeft).Column
Ws.Range(Ws.Cells(1, 7), Ws.Cells(LRow, LCol)).Delete
Ws.Range("C1").End(xlDown).Offset(1).Resize(Ws.UsedRange.Rows.Count).EntireRow.Delete
Ws.Columns.AutoFit
LRow = Ws.Range("A" & Rows.Count).End(xlUp).Row
Ws.Range("A1:F" & LRow).Copy

AppWord.Visible = True
Set WordDoc = AppWord.Documents.Add

With WordDoc
    .Content.Paste
    .SaveAs Filename:=ThisWorkbook.Path & "\" & "Waypoint" & ".docx"
End With
Application.CutCopyMode = False
AppWord.Quit
Set WordDoc = Nothing
Set AppWord = Nothing
With Application
    .ScreenUpdating = True
    .DisplayStatusBar = True
    .StatusBar = False
    .EnableEvents = True
    .Calculation = xlAutomatic
End With
End Sub

Open in new window

Please make sure you have clicked Word Reference before running the code. Here is the link which will guide you how to get reference ticked :)
Andrea_Table_Cleanup_v1.xlsm

Andreamary

ASKER

Super! Thanks so much, Shums! The only tweak I need is for the Excel data to be pasted into Word `as text` so it has a tabs between each value (so we can apply a paragraph style with the tab values already established)...

ASKER CERTIFIED SOLUTION

Shums Faruk

membership

This solution is only available to members.

To access this solution, you must be a member of Experts Exchange.

Start Free Trial

Andreamary

ASKER

I gave that a try, and tried it a couple of times, and it still seems to be pasting into Word as a table instead of text (so not with tabs between the data)...

Shums Faruk

Sorry, just check the last one, you tried before refreshing the page :)

Andreamary

ASKER

Perfection!! Thanks a bunch, Shums, for a quick and excellent solution! :-)

Andreamary

ASKER

Very much appreciated, Shums!

Shums Faruk

You're Welcome Andrea! Glad I was able to help :)