combine_sheets.vba 1.4 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445
  1. Sub CombineSheetsIntoSheet()
  2. Dim wb As Workbook
  3. Dim j As Integer, wsNew As Worksheet
  4. Dim rngCopy As Range, rngPaste As Range
  5. Dim Location As String
  6. Set wb = ActiveWorkbook
  7. On Error Resume Next
  8. Set wsNew = wb.Sheets("Combined")
  9. On Error GoTo 0
  10. 'if sheet does not already exist, create it
  11. If wsNew Is Nothing Then
  12. Set wsNew = wb.Worksheets.Add(before:=wb.Sheets(1)) ' add a sheet in first place
  13. wsNew.Name = "Combined"
  14. End If
  15. 'copy headings and paste to new sheet starting in B1
  16. With wb.Sheets(2)
  17. .Range(.Range("A1"), .Cells(1, Columns.Count) _
  18. .End(xlToLeft)).Copy wsNew.Range("B1")
  19. End With
  20. ' work through sheets
  21. For j = 2 To wb.Sheets.Count ' from sheet 2 to last sheet
  22. 'save sheet name/location to string
  23. Location = wb.Sheets(j).Name
  24. 'set range to be copied
  25. With wb.Sheets(j).Range("A1").CurrentRegion
  26. Set rngCopy = .Offset(1, 0).Resize(.Rows.Count - 1)
  27. End With
  28. 'set range to paste to, beginning with column B
  29. Set rngPaste = wsNew.Cells(Rows.Count, 2).End(xlUp).Offset(2, 0)
  30. 'copy range and paste to column *B* of combined sheet
  31. rngCopy.Copy rngPaste
  32. 'enter the location name in column A for all copied entries
  33. wsNew.Range(rngPaste, rngPaste.End(xlDown)).Offset(0, -1) = Location
  34. Next j
  35. End Sub