Macro to append data

[VegasNath]

My workplace has blacklisted Eileen's lounge, how rude!! I'm on the case though, not a resource I can do without. It tickles me how I can still access all the sport, games, etc, even book my annual holiday....

This is what I was going to post earlier:

I have 2 workbooks open, both with multiple identically named sheets. I would like to run a macro in wb1 (Active) to copy the selected range from each worksheet and paste to the corresponding worksheet in wb2 to the next blank column, row 6.

This is what i came up with (using a function for obtaining the column letter)

Code: Select all

Sub Append()

Dim wb1 As Workbook, wb2 As Workbook
Dim wsName As String
Dim ws As Worksheet
Dim strCol As String

Set wb1 = ActiveWorkbook
Set wb2 = Excel.Workbooks("xyz.xls")	'Also open

Application.ScreenUpdating = False

If ActiveSheet.Index = Sheets.Count Then
    MsgBox "Process complete.", vbInformation, "Macro"
Else
    Selection.Copy
    wsName = ActiveSheet.Name
    wb2.Activate
    wb2.Sheets(wsName).Select
    strCol = LastCol(6, "IV", wb2.Sheets(wsName), 1)
    Range(strCol & "6").Select
    ActiveSheet.Paste
    wb1.Activate
    ActiveSheet.Next.Select
    Call Append
End If

Application.ScreenUpdating = True

End Sub

Not a very attractive approach (re-calling Append for each worksheet), any suggestions for improvement?

Also, if there is no corresponding ws in wb2, I would like to create one by copying the last ws in wb2 and renaming it, then paste.

[HansV]

So you want to start at the currently active sheet in wb1 and work your way to the last sheet? Or do you want to loop through all sheets in wb1?

PS What was the reason for blacklisting us?

[VegasNath]

So you want to start at the currently active sheet in wb1 and work your way to the last sheet?

Yes please.

PS What was the reason for blacklisting us?

No idea. The page that loads states inappropriate content. Apparently many sites that could be viewed previously are no longer viewable, many people have apparently complained about different sites. It may coincide with the fact that some people were able to stream live world cup games which overloaded the server. I am hoping that my request to unblock will be granted.

[HansV]

Try this:

Code: Select all

Sub Append2()
  Dim wb1 As Workbook
  Dim wb2 As Workbook
  Dim wsh1 As Worksheet
  Dim wsh2 As Worksheet
  Set wb1 = ActiveWorkbook
  Set wb2 = Workbooks("xyz.xls")
  Set wsh1 = wb1.ActiveSheet
  On Error GoTo ErrHandler
  Do
    wsh1.Select
    Set wsh2 = wb2.Worksheets(wsh1.Name)
    Selection.Copy Destination:=wsh2.Cells(6, wsh2.Columns.Count).End(xlToLeft).Offset(0, 1)
    Set wsh1 = wsh1.Next
  Loop Until wsh1 Is Nothing
  Exit Sub

ErrHandler:
  If Err = 9 Then
    ' Copy last sheet
    wb2.Worksheets(wb2.Worksheets.Count).Copy Before:=wb2.Worksheets(wb2.Worksheets.Count)
    Set wsh2 = wb2.Worksheets(wb2.Worksheets.Count - 1)
    wsh2.Name = wsh1.Name
    ' Copying a sheet activates it, so move back to wb1
    wb1.Activate
    Resume Next
  Else
    MsgBox Err.Description, vbExclamation
  End If
End Sub

[VegasNath]

Works Great Hans, Thankyou.

One question, when a new sheet is created in wb2, I would like to clear the contents of the last used column BELOW row 6. How can I reference that?

ws2.Range("").ClearContents

[HansV]

What is "the last used column BELOW row 6"?

[VegasNath]

Sorry, I want to clear the last used column, but not row 6. EG: W7:W200, W being the last used column.

[HansV]

Should we look in row 6 for the last used column, or at the entire sheet?

[VegasNath]

Should we look in row 6 for the last used column?

yes, (6, wsh2.Columns.Count).End(xlToLeft)

[HansV]

Code: Select all

Sub Append2()
  Dim wb1 As Workbook
  Dim wb2 As Workbook
  Dim wsh1 As Worksheet
  Dim wsh2 As Worksheet
  Dim m As Long
  Set wb1 = ActiveWorkbook
  Set wb2 = Workbooks("xyz.xls")
  Set wsh1 = wb1.ActiveSheet
  On Error GoTo ErrHandler
  Do
    wsh1.Select
    Set wsh2 = wb2.Worksheets(wsh1.Name)
    Selection.Copy Destination:=wsh2.Cells(6, wsh2.Columns.Count).End(xlToLeft).Offset(0, 1)
    Set wsh1 = wsh1.Next
  Loop Until wsh1 Is Nothing
  Exit Sub

ErrHandler:
  If Err = 9 Then
    ' Copy last sheet
    wb2.Worksheets(wb2.Worksheets.Count).Copy Before:=wb2.Worksheets(wb2.Worksheets.Count)
    Set wsh2 = wb2.Worksheets(wb2.Worksheets.Count - 1)
    wsh2.Name = wsh1.Name
    m = wsh2.Cells(6, wsh2.Columns.Count).End(xlToLeft).Column
    wsh2.Range(wsh2.Cells(7, m), wsh2.Cells(wsh2.Rows.Count, m)).ClearContents
    ' Copying a sheet activates it, so move back to wb1
    wb1.Activate
    Resume Next
  Else
    MsgBox Err.Description, vbExclamation
  End If
End Sub

[VegasNath]

Thanks Hans.