Deleting a Particular Column with IF Condition before Pasting

[madhuchelliah]

Hello Folks, Please go through the code i mentioned. The code is intended to copy all the sheets from source workbook and paste to another workbook's single sheet. My requirement is before pasting all the sheets it should look for E1 cell in all the sheets, IF the E1 cell is blank it should delete the entire column and then paste ELSE just copy paste all the sheet. Also if possible please add the the file open default location should be in desktop.



Sub Import()

Dim wb1 As Workbook
Dim wb2 As Workbook
Dim Sheet As Worksheet
Dim PasteStart As Range

Set wb1 = ActiveWorkbook
Set PasteStart = [Sheet1!C2]

Sheets("Sheet1").Select
Cells.Select
Selection.ClearContents

FileToOpen = Application.GetOpenFilename _
(Title:="Please Select Your File", _
FileFilter:="Report Files *.xlsx (*.xlsx),")

If FileToOpen = False Then
MsgBox "No XML Selected.", vbExclamation, "ERROR"
Exit Sub
Else
Set wb2 = Workbooks.Open(Filename:=FileToOpen)

For Each Sheet In wb2.Sheets
With Sheet.UsedRange
.Copy PasteStart
Set PasteStart = PasteStart.Offset(.Rows.Count)
End With
Next Sheet

End If

wb2.Close
End Sub

 

[madhuchelliah]

How about

Sub Import()

   Dim wb1 As Workbook
   Dim wb2 As Workbook
   Dim Ws As Worksheet
   Dim PasteStart As Range
   Dim FileToOpen As String
   
Application.ScreenUpdating = False

   Set wb1 = ActiveWorkbook
   Set PasteStart = wb1.Sheets("Sheet1").Range("C2")
   
   Sheets("Sheet1").Cells.ClearContents
   
   ChDrive "C:"
   ChDir "[COLOR=#ff0000]C:\Users\Fluff\Desktop\[/COLOR]"
   
   FileToOpen = Application.GetOpenFilename _
      (Title:="Please Select Your File", _
      FileFilter:="Report Files *.xlsx (*.xlsx),")
   
   If FileToOpen = False Then
      MsgBox "No XML Selected.", vbExclamation, "ERROR"
      Exit Sub
   End If
   Set wb2 = Workbooks.Open(FileName:=FileToOpen)
   
   For Each Ws In wb2.Worksheets
      If Ws.Range("E1") = "" Then Ws.Columns("E").Delete
      With Ws.UsedRange
         .copy PasteStart
         Set PasteStart = PasteStart.Offset(.Rows.Count)
      End With
   Next Ws
   
   wb2.Close
End Sub

Change the line in red, to match your default path

Hello Fluff, adding to the above code, Is it possible to delete the content before the last space of A2 cell in all sheets before pasting? for Example if the cell contains 81 A 1 i want to delete 81 A and the result would be 1. please help. Thank you.

 

[Fluff]

Try

Sub Import()

   Dim wb1 As Workbook
   Dim wb2 As Workbook
   Dim Ws As Worksheet
   Dim PasteStart As Range
   Dim FileToOpen As String
   
Application.ScreenUpdating = False

   Set wb1 = ActiveWorkbook
   Set PasteStart = wb1.Sheets("Sheet1").Range("C2")
   
   Sheets("Sheet1").Cells.ClearContents
   
   ChDrive "C:"
   ChDir "C:\Users\" & Environ("Username") & "\Desktop\"
   
   FileToOpen = Application.GetOpenFilename _
      (Title:="Please Select Your File", _
      FileFilter:="Report Files *.xlsx (*.xlsx),")
   
   If FileToOpen = "False" Then
      MsgBox "No XML Selected.", vbExclamation, "ERROR"
      Exit Sub
   End If
   Set wb2 = Workbooks.Open(FileName:=FileToOpen)
   
   For Each Ws In wb2.Worksheets
      With Ws.Range("A2")
         .Value = Right(.Value, Len(.Value) - InStrRev(.Value, " "))
      End With
      If Ws.Range("E1") = "" Then Ws.Columns("E").Delete
      With Ws.UsedRange
         .Copy PasteStart
         Set PasteStart = PasteStart.Offset(.Rows.Count)
      End With
   Next Ws
   
   wb2.Close True
End Sub

 

[madhuchelliah]

Thanks Fluff working great!!!!!!!!!

 

[Fluff]

Glad to help & thanks for the feedback