none
Problem during copy data from one workbook to another workbook using vba RRS feed

  • Question

  • Hi everyone,

    I want to copy some data from a workbook to another workbook. The scenario is like - I have one excel sheet(Sheet1) in which I have one command button. When I click on that button it will prompt user to select a workbook from which user wants to copy data. Data to be copied from "Data" sheet of the selected workbook and I want to paste it in my current workbook(Sheet2) from A5 cell. I have come up with the below code but I'm not able to figure out why it's not working.

    Sub Copy()

    On Error Resume Next Application.ScreenUpdating = False Dim wkbCrntWorkBook As Workbook Dim wkbSourceBook As Workbook Dim rngSourceRange As Range Dim rngDestination As Range Dim intColumnCount As Integer Set wkbCrntWorkBook = ActiveWorkbook With Application.FileDialog(msoFileDialogOpen) .Filters.Clear .Filters.Add "Excel 2007", "*.xlsx; *.xlsm; *.xlsa", 1 .Filters.Add "Excel 2002-03", "*.xls", 2 .AllowMultiSelect = False .Show If .SelectedItems.count > 0 Then Workbooks.Open .SelectedItems(1) Set wkbSourceBook = ActiveWorkbook 'ActiveWorkbook.Windows(1).Visible = False For a = 1 To 50 For b = 1 To 500 If wkbSourceBook.Worksheets("Data").Cells(b, a) <> "" Then firstCol = a FirstRow = b firstRangeVal = wkbSourceBook.Worksheets("Data").Cells(b, a).Address a = 255 b = 500 End If Next b Next a For a = firstCol To 255 For b = FirstRow To 500 If wkbSourceBook.Worksheets("Data").Cells(b, a) = "" And wkbSourceBook.Worksheets("Data").Cells(b, a).Previous <> "" Then lastCol = a - 1 b = 500 End If Next b Next a For b = FirstRow To 500 c = 0 For a = firstCol To lastCol If wkbSourceBook.Worksheets("Data").Cells(b, a) = "" Then c = c + 1 End If Next a If c = (firstCol + lastCol) - 1 Then LastRow = b - 1 b = 500 End If Next b lastRangeVal = wkbSourceBook.Worksheets("Data").Cells(LastRow, lastCol).Address wkbSourceBook.Worksheets("Data").Range(firstRangeVal, lastRangeVal).Select Selection.Copy ' wkbCrntWorkBook.ActiveSheet.Range("A1:Z100").Value = wkbSourceBook.Worksheets("Sheet2").UsedRange.vaule ' wkbSourceBook.Worksheets("Sheet2").Range(firstRangeVal, lastRangeVal).Copy ' wkbCrntWorkBook.Activate wkbCrntWorkBook.Worksheets("Sheet2").Activate wkbCrntWorkBook.ActiveSheet.Range("C15").Select Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False Application.CutCopyMode = False wkbSourceBook.Close False End If End With Set wkbCrntWorkBook = Nothing Set wkbSourceBook = Nothing Set rngSourceRange = Nothing Set rngDestination = Nothing intColumnCount = Empty Application.ScreenUpdating = True

    End Sub

     I want to copy everything from "Data" sheet of the selected workbook and paste it in my Sheet2 from A5 cell. Before the code paste data in Sheet2 I want to clear the sheet so that existing data get erased. But I want to erase it from A5 cell because up to row 4 I have some other data that I don't want to delete.

    Can anyone help me to find the resolution of the above problem.

    Thanks.

      


    • Edited by Ed_Dao Tuesday, June 9, 2015 5:19 PM
    Tuesday, June 9, 2015 5:17 PM

Answers

  • Try it like this:

    Sub CopyV2()
        Dim wkbCrntWorkBook As Workbook
        Dim wkbSourceBook   As Workbook
          
        Application.ScreenUpdating = False
        Application.DisplayAlerts = False
        
        Set wkbCrntWorkBook = ActiveWorkbook
        wkbCrntWorkBook.Worksheets("Sheet2").UsedRange.Offset(4).ClearContents
        
        With Application.FileDialog(msoFileDialogOpen)
            .Filters.Clear
            .Filters.Add "Excel 2007", "*.xlsx; *.xlsm; *.xlsa", 1
            .Filters.Add "Excel 2002-03", "*.xls", 2
            .AllowMultiSelect = False
            .Show
            If .SelectedItems.Count = 0 Then
                MsgBox "You cancelled."
                Exit Sub
            End If
            Set wkbSourceBook = Workbooks.Open(.SelectedItems(1))
        End With
        
        
        wkbSourceBook.Worksheets("Data").UsedRange.Copy   
        wkbCrntWorkBook.Worksheets("Sheet2").Range("A5").PasteSpecial Paste:=xlPasteValues
        wkbSourceBook.Close False
        
        Set wkbCrntWorkBook = Nothing
        Set wkbSourceBook = Nothing
        
        Application.ScreenUpdating = True
        Application.DisplayAlerts = True

    End Sub

    • Marked as answer by Ed_Dao Wednesday, June 17, 2015 5:39 PM
    Tuesday, June 9, 2015 7:30 PM

All replies

  • Hi,

    I'll examine your code later. But at first, "With" and "End With" is too far, i.e. "End With" should be placed after ".Show", Ithink. And I'd like to ask why so many sentences are green. They are commented, or literal?


    • Edited by Ashidacchi Tuesday, June 9, 2015 7:25 PM
    Tuesday, June 9, 2015 7:24 PM
  • Try it like this:

    Sub CopyV2()
        Dim wkbCrntWorkBook As Workbook
        Dim wkbSourceBook   As Workbook
          
        Application.ScreenUpdating = False
        Application.DisplayAlerts = False
        
        Set wkbCrntWorkBook = ActiveWorkbook
        wkbCrntWorkBook.Worksheets("Sheet2").UsedRange.Offset(4).ClearContents
        
        With Application.FileDialog(msoFileDialogOpen)
            .Filters.Clear
            .Filters.Add "Excel 2007", "*.xlsx; *.xlsm; *.xlsa", 1
            .Filters.Add "Excel 2002-03", "*.xls", 2
            .AllowMultiSelect = False
            .Show
            If .SelectedItems.Count = 0 Then
                MsgBox "You cancelled."
                Exit Sub
            End If
            Set wkbSourceBook = Workbooks.Open(.SelectedItems(1))
        End With
        
        
        wkbSourceBook.Worksheets("Data").UsedRange.Copy   
        wkbCrntWorkBook.Worksheets("Sheet2").Range("A5").PasteSpecial Paste:=xlPasteValues
        wkbSourceBook.Close False
        
        Set wkbCrntWorkBook = Nothing
        Set wkbSourceBook = Nothing
        
        Application.ScreenUpdating = True
        Application.DisplayAlerts = True

    End Sub

    • Marked as answer by Ed_Dao Wednesday, June 17, 2015 5:39 PM
    Tuesday, June 9, 2015 7:30 PM