vba to copy data and rearrange data from one spreadsheet to another

Question

I'm new to this forum, and in need of some help with getting information from a budget spreadsheet to a workbook. The spreadsheet I'm pulling from has data spread out in multiple columns and rows, and there are many blank cells, but I need it to be laid out in a line-item format in the workbook with no blanks. I'm able to manually link each cell and row in each sheet, but it requires a lot of code and isn't very elegant. I think my best option is to run a loop through Column B, and if there's a value there, then copy all cells with a value in that row to the new sheet.

This is the code I have so far:

Private Sub ImportBudget_Click()
Dim BudgetBook As Workbook
Dim filter As String
Dim caption As String
Dim BudgetFileName As String
Dim ActiveBook As Workbook
Dim targetWorkbook As Workbook

Set targetWorkbook = Application.ActiveWorkbook

' get the budget workbook
 filter = "Excel files (*.xlsx),*.xlsx"
 caption = "Please Select an input file "
 BudgetFileName = Application.GetOpenFilename(filter, , caption)

 Set BudgetBook = Application.Workbooks.Open(BudgetFileName)

 ' copy data from budget to target workbook
 Dim targetSheet As Worksheet
 Set targetSheet = targetWorkbook.Worksheets(1)
 Dim sourceSheet As Worksheet
 Set sourceSheet = BudgetBook.Worksheets(1)
 Dim i As Integer
 Dim j As Integer
  j = 2
   For i = 2 To 300
    If sourceSheet.Cells(i, 2).Value <> "" And sourceSheet.Cells(i, 1) <> "" Then
    targetSheet.Cells(j, 1).Value = sourceSheet.Cells(i, 1).Value
    targetSheet.Cells(j, 2).Value = sourceSheet.Cells(i, 2).Value
    targetSheet.Cells(j, 3).Value = sourceSheet.Cells(i, 3).Value
     j = j + 1

   End If
  Next i

 BudgetBook.Close
End Sub

The problem with this is that it works well for just one section of the original spreadsheet, however, some areas have up to 9 columns of data in the row. Additionally, because the budget sheet is broken up into different sections, should I rewrite this same code for each section, changing i to the new range?

Answer 1

This will loop through sourceSheet and any row between 2 and 300 that has a value in column A or B (1 or 2) it will take and loop through all columns between 1 and the last column with data. Then, all non-blank cells within that column range, and in that row, will be put into targetSheet in a new row with no spaces between the data in the columns.

Option Explicit
Private Sub ImportBudget_Click()
Dim BudgetBook As Workbook
Dim filter As String
Dim caption As String
Dim BudgetFileName As String
Dim ActiveBook As Workbook
Dim targetWorkbook As Workbook
Dim i as Single, k as Single, counter as Single

Set targetWorkbook = Application.ActiveWorkbook

' get the budget workbook
 filter = "Excel files (*.xlsx),*.xlsx"
 caption = "Please Select an input file "
 BudgetFileName = Application.GetOpenFilename(filter, , caption)

 Set BudgetBook = Application.Workbooks.Open(BudgetFileName)

 ' copy data from budget to target workbook
 Dim targetSheet As Worksheet
 Set targetSheet = targetWorkbook.Worksheets(1)
 Dim sourceSheet As Worksheet
 Set sourceSheet = BudgetBook.Worksheets(1)

 j = 2

 With sourceSheet
   For i = 2 To 300
    If .Cells(i, 2).Value <> "" And .Cells(i, 1) <> "" Then

       counter = 1

       For k = 1 to .Cells(i,.Columns.Count).End(xlToLeft).Column
          If .Cells(i,k) <> "" Then
             targetSheet.Cells(j,counter) = .Cells(i,k)
             counter = counter + 1
          End if
       Next k
     j = j + 1

   End If
  Next i
 End With

 BudgetBook.Close
End Sub

Answer 2

If you just want to skip the blank rows, then something like this

Set sourceRange = sourceSheet.UsedRange.SpecialCells(xlCellTypeConstants)

Set sourceRange = Intersect(sourceRange.EntireRow, sourceRange.EntireColumn)

sourceRange.Copy

targetSheet.Paste

If you have formulas or anything else that is not copied, let me know.