CODEWITHSUNDEEP
excelvbacopy-paste
Samiko
Samiko

Reputation: 191

When pasting data from one workbook to another, overalpping data or data not showing at all.

I'm new to VBA so not exactly sure how this all works but I've got the jist. I am trying to import data from multiple workbooks into one workbook that is created by the program. I have got the main importing done correctly (although not effeciently) but then one of three things happens: The data is imported into correct places and is fine, the data overlaps after the first set, or only the first set of data is transferred. I just can't work out why! 

  Do 
     Filename = InputBox("What is the full path and name of the file?")      
     Workbooks.Open (Filename)
     data_range = InputBox("What is the cell range of the wanted data in the original file? If this is the first set of data, include the titles for reference")
     ActiveSheet.Range(data_range).Select
     Selection.Copy
     ActiveWorkbook.Close
    If first = True Then
      ActiveSheet.Range("b2").Select
    End If
    If first = False Then
      ActiveSheet.Range("b" & (difference + 3)).Select
    End If

    ActiveSheet.Paste
    ActiveSheet.Range("a1").Select
    again = MsgBox("Would you like to import another set of data?", 4)
    Call start_cell(range_of_cells, data_range)
    first = False

  Loop Until again = vbNo

That was the main program. The sub-procedure start_cell is below:

    range_of_cells = Split(data_range, ":")
    NUMBERS(0) = Right(range_of_cells(0), 2)
    NUMBERS(1) = Right(range_of_cells(1), 2)

    check = IsNumeric(NUMBERS(0))
    If check = False Then
        'wrong
    End If
    check = IsNumeric(NUMBERS(1))
    If check = False Then
        'wrong
    End If

    difference = (NUMBERS(1) - NUMBERS(0)) + difference

Any help would be awesome. Also if there are any more effecient ways that'd be great.

Upvotes: 1

Views: 52

Answers (1)

xificurC
xificurC

Reputation: 1178

This is a sketch of what could work, check it, run it, customize it and let me know if something isn't working or I misunderstood your question.

Function GetFolder(ByVal sTitle As String) As String
    With Application.FileDialog(msoFileDialogFolderPicker)
        .AllowMultiSelect = False
        .Title = sTitle
        .Show
        On Error Resume Next
        GetFolder = .SelectedItems(1)
        On Error GoTo 0
    End With
End Function

Sub Main()

    Const START_ADDR As String = "A17"
    Dim sPath As String, sFile As String
    Dim wbLoop As Workbook
    Dim wsLoop As Worksheet, wsConsolidate As Worksheet
    Dim rData As Range

    'save current sheet in variable (change if required)
    wsConsolidate = ActiveSheet

    'ask for folder
    sPath = GetFolder("Select the folder where your files reside.")
    'if none provided quit
    If sPath = "" Then
        MsgBox "No folder selected."
        Exit Sub
    End If

    'get all excel files from specified folder
    sFile = Dir(sPath & "\*.xls*")
    Do Until sFile = ""
        'open file
        Set wbLoop = Workbooks.Open(sPath & "\" & sFile)
        Set wsLoop = wbLoop.Sheets(1) 'change if other
        'copy data out
        Set rData = wsLoop.Range(START_ADDR).CurrentRegion
        'if the data has headers uncomment below
        'Set rData = rData.Offset(1, 0).Resize(rData.Rows.Count)
        rData.Copy wsConsolidate.Cells(wsConsolidate.Rows.Count, "B").End(xlUp).Offset(1, 0)
        'close file without saving
        wbLoop.Close False
        'loop through files
        sFile = Dir
    Loop

End Sub

Upvotes: 2

Related Questions