Solved: delete some columns and add borders using macro

[reza_doang]

Dear All,

i really need your help to save my time, because i should do this for 459 worksheets :(. OK, i attach my sample and here my situation, i copy data from website and paste special--text (in data worksheet). And now i want to print out that data, but not for all columns and i should go to page setup to setting the pages. If this possible, can macro:
1. Delete all column with header NPSN, NSS, OP
2. After deleting column NPSN, NSS & OP then creating borders like sample.
3. Finally, can vba create auto setting to print out data, for every width page until status, for height it doesn't matter for many pages. ( to more clear, please see the sample).

i really2 need you help to save my time, : pray2: :help
i know for no. 3 maybe difficult, at least for no. 1 and 2 you can help me.

many thanks

reza

[slamet Harto]

Let me try No 1, or perhaps other expert will answer on Question 2 & 3

Or You do your own record macro

Sub DEL()

Dim LastCol As Long

With Application

.ScreenUpdating = False
.Calculation = xlCalculationManual
End With

[A1].Select
With ActiveSheet

LastCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
For i = LastCol To 1 Step -1

If .Cells(ActiveCell.Row, i).Value Like "*NSS*" Or _
.Cells(ActiveCell.Row, i).Value Like "*NPSN*" Or _
.Cells(ActiveCell.Row, i).Value Like "*Op*" Or _
.Cells(ActiveCell.Row, i).Value = "" Then

.Columns(i).Delete
End If
Next i

End With

With Application

.Calculation = xlCalculationAutomatic
.ScreenUpdating = True
End With
End Sub

[Artik]

Try this:Sub DeleteAndFormat()
Application.ScreenUpdating = False

If DeleteColumns(ActiveSheet) Then
Call Formatting(ActiveSheet)
End If

Application.ScreenUpdating = True
End Sub

Private Function DeleteColumns(Wks As Worksheet) As Boolean
Dim iLastColumn As Integer
Dim rngColsToDel As Range
Dim i As Integer

With Wks
iLastColumn = .Cells(1, .Columns.Count).End(xlToLeft).Column

For i = 1 To iLastColumn
With .Cells(1, i)

If .Value Like "*NSS*" Or _
.Value Like "*NPSN*" Or _
.Value Like "*Op*" Or _
IsEmpty(.Cells) Then

If rngColsToDel Is Nothing Then
Set rngColsToDel = .Cells
Else
Set rngColsToDel = Union(rngColsToDel, .Cells)
End If

End If

End With
Next i
End With

If Not rngColsToDel Is Nothing Then
rngColsToDel.EntireColumn.Delete
DeleteColumns = True
Set rngColsToDel = Nothing
End If
End Function

Private Sub Formatting(Wks As Worksheet)
Dim rngLastColumn As Range
Dim rgnCellsWithData As Range
Dim rngTmp As Range
Dim rngHeader As Range
Dim colAreasWithData As New Collection
Dim i As Integer

With Wks
Set rngLastColumn = .Cells(1, .Columns.Count).End(xlToLeft)
Set rngHeader = .Range(.[A1], rngLastColumn)

For i = 1 To rngLastColumn.Column Step 4
Set rngTmp = .Cells(Rows.Count, i).End(xlUp).Offset(, 3)
If rgnCellsWithData Is Nothing Then
Set rgnCellsWithData = .Range(.Cells(1, i), rngTmp)
Else
Set rgnCellsWithData = Union(rgnCellsWithData, .Range(.Cells(1, i), rngTmp))
End If

colAreasWithData.Add .Range(.Cells(1, i), rngTmp), CStr(i \ 4 + 1)
Next i
End With

With rgnCellsWithData.Borders
.LineStyle = xlContinuous
.Weight = xlHairline
.ColorIndex = xlAutomatic
End With

With rngHeader
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.Font.Bold = True

With .Interior
.ColorIndex = 37
.Pattern = xlSolid
End With

.EntireColumn.AutoFit
End With

Wks.Activate
ActiveWindow.View = xlPageBreakPreview

On Error Resume Next
For i = 1 To colAreasWithData.Count
With colAreasWithData(i)
.BorderAround LineStyle:=xlContinuous, ColorIndex:=xlAutomatic, Weight:=xlThin

Set Wks.VPageBreaks(i).Location = colAreasWithData(i + 1)(1)
End With
Next i
On Error GoTo 0

ActiveWindow.View = xlNormalView
Wks.DisplayPageBreaks = False

Set rngLastColumn = Nothing
Set rgnCellsWithData = Nothing
Set rngTmp = Nothing
Set rngHeader = Nothing

End Sub
Artik

[reza_doang]

Artic...

its work, many thanks for your help.
You save my time...
:bow::bow::bow:

[Artik]

reza_doang

slamet Harto thank you too, because he made a part of the job. :clap2:

Artik