Public Sub subReports()
Dim rngColumn As Range
Dim rngUnion As Range
Dim rng As Range
Dim intColumn As Integer
Dim intCount As Integer
Dim WbSource As Workbook
Dim WbTarget As Workbook
Dim WsSource As Worksheet
Dim WsTarget As Worksheet
Dim strFileName ' As String
Dim intSave As Integer
Dim i As Integer
Dim strMsg As String
Dim strPad As String
Dim strReportTitle As String
On Error GoTo Err_Handler
ActiveWorkbook.Save
If MsgBox("Copy data from this worksheet?", vbYesNo, "Check") = vbNo Then
Exit Sub
End If
intSave = Application.SheetsInNewWorkbook
Application.SheetsInNewWorkbook = 1
Set WbSource = ActiveWorkbook
strFileName = Application.GetSaveAsFilename("Dummy.xlsx", _
"Excel files,*.xlsx", 1, "Select your folder and filename")
If strFileName = False Then
Application.SheetsInNewWorkbook = intSave
Exit Sub
End If
Call subUnloadWorkbook(strFileName)
WbSource.Activate
If Dir(strFileName) <> "" Then
On Error Resume Next
Kill strFileName
On Error GoTo Err_Handler
End If
Workbooks.Add
ActiveWorkbook.SaveAs strFileName
Application.SheetsInNewWorkbook = intSave
Set WbTarget = ActiveWorkbook
WbSource.Activate
Set WsSource = ActiveSheet
WsSource.Activate
Set WsTarget = WbTarget.Sheets(1)
WsTarget.Name = "Report"
intColumn = 0
Do While True
On Error Resume Next
Set rngColumn = Nothing
Set rngColumn = Application.InputBox(strMsg, "Select columns.", , , , , , 8)
On Error GoTo 0
If Not rngColumn Is Nothing Then
intCount = intCount + rngColumn.Columns.Count
For i = 1 To rngColumn.Columns.Count
intColumn = intColumn + 1
If intColumn <= 9 Then
strPad = " "
Else
strPad = ""
End If
strMsg = strMsg & vbCrLf & strPad & intColumn & " " & rngColumn.Cells(1, i)
Next i
If Not rngUnion Is Nothing Then
Set rngUnion = Union(rngUnion, rngColumn)
Else
Set rngUnion = rngColumn
End If
Else
Exit Do
End If
Loop
WsTarget.Activate
If Not rngUnion Is Nothing Then
WsTarget.Cells.Clear
intColumn = 1
For Each rng In rngUnion.Areas
rng.EntireColumn.Copy
WsTarget.Cells(1, intColumn).Select
Selection.PasteSpecial Paste:=xlPasteAllUsingSourceTheme, Operation:=xlNone _
, SkipBlanks:=False, Transpose:=False
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
intColumn = intColumn + rng.Columns.Count
Next rng
End If
WbTarget.Activate
With WbTarget
.Sheets(1).Range("A1").Select
.Save
.Close
End With
WbSource.Activate
WsSource.Range("A1").Select
If intColumn = 0 Then
MsgBox "No columns have been copied.", vbOKOnly, "Confirmation"
Else
MsgBox intColumn - 1 & " Columns copied." & vbCrLf & strMsg, vbOKOnly, "Confirmation"
End If
Exit_Handler:
Exit Sub
Err_Handler:
MsgBox "An error has occured.", vbOKOnly, "Warning"
Resume Exit_Handler
End Sub
Public Sub subUnloadWorkbook(ByVal strWorkbook As String)
Dim Wb As Workbook
For Each Wb In Application.Workbooks
If strWorkbook = Wb.FullName Then
Wb.Close True
Exit For
End If
Next Wb
End Sub