Attempting importing sheet from data file into destination file.

LZ_Code

New Member
Joined
Jan 30, 2025
Messages
17
Office Version
  1. 365
Platform
  1. Windows
I am Attempting this code and use it. But for some reason when importing worksheet it uploads the worksheet that is selected by the user when prompted instead of naming the sheet 'Import'. There for cant hide the tab that is imported. Also I am attempting to copy data from 'Import' to new Sheet2, since the data from 'Import' will be different every time. need it to scan and import to selected range in new sheet2

This is original Post

VBA Code:
Option Explicit
Sub ImportData()
    
    Dim OpenBook As Workbook
    Dim TargetFile As String, msg As String, FileName As String, response As String
    Dim lngCount As Long, i As Long, x As Long, counter As Long
    Dim ws As Worksheet

    'Prompts user to select and open a workbook (no screen updating)
    'The open/selected workbook is recorded as being "TargetFile"
    
    'Open the file dialog
    With Application.FileDialog(3) '3 = msoFileDialogOpen
        .AllowMultiSelect = False
        If .Show = -1 Then
            For lngCount = 1 To .SelectedItems.Count
                Set OpenBook = Workbooks.Open(CStr(.SelectedItems(lngCount))) 'Assumes the workbook is not already open
                TargetFile = Dir(CStr(.SelectedItems(lngCount)))
            Next lngCount
        Else
            Exit Sub
        End If
    End With
    
    Application.ScreenUpdating = False
  
    'The following code looks at the newly selected/opened workbook, then prompts the user to choose which worksheet to copy from
    'The information is then copied into the 'Import' tab
    
    msg = "Choose Project BOM to copy from """ & TargetFile & """?"
  
    With Workbooks(TargetFile)
        For i = 1 To .Worksheets.Count
            msg = msg & vbCrLf & "(" & i & ") " & .Worksheets(i).Name
        Next i
        
        response = InputBox(msg, "Type numbers for sheets to import")
  
        If response = "" Then Exit Sub 'check for cancel button
        
        On Error Resume Next
            Set ws = .Worksheets(CLng(response))
            If Err.Number = 0 Then
                ws.Copy After:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count) 'Copies the chosen worksheet into 'Import' tab
                ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count).Name = "Import" 'Name uploads as the worksheet chossen by user not 'Import'
           
            End If
        On Error GoTo 0
    End With
    
    'This routine pastes the path of the chosen/selected file on cell B6 of the 'Status' tab/sheet
    ThisWorkbook.Sheets("PAGE").Range("B2").Value = TargetFile
    
    ThisWorkbook.Sheets("Import").Visible = False

  
    'Closes the chosen workbook file without making any saves or changes (no screen updating)
    Workbooks(TargetFile).Close SaveChanges:=False
    Application.ScreenUpdating = True
  
    'Attempting to copy data that is on 'Import' sheet to new Destination Sheet, rows may differ depending on Import data. Also need to import data but keep destination format
    Sheets("Import").Range("B4:E4").Copy Destination:=Sheets("Sheet2").Range("A13:D13")End(xlUp).Value = .SpecialCells(xlConstants).Value
  
  
End Sub
 
Change rowFirst to look at Column B
And Set sourceRng to start from Column B.
I erased the full on rows above it seems to work as coded. I mean I guess the user can erase the column's IDs and Copy and paste the format I erased.

1738605100741.png
 
Upvote 0

Excel Facts

Quick Sum
Select a range of cells. The total appears in bottom right of Excel screen. Right-click total to add Max, Min, Count, Average.
If you want to confirm that sheet 2 has headings in row 11 and that you want previous data cleared from row 13 down for Columns A-D and new data copied from A13 down then I can modify accordingly.
 
Upvote 0
See if this does what you need. You shouldn't need to do any manual manipulation.

VBA Code:
Sub ExtractData_v02()

    Dim sourceSheet As Worksheet
    Dim destinationSheet As Worksheet
    Dim rowFirst As Long, rowLast As Long
    Dim sourceRng As Range
    Dim destRowFirst As Long, destRowLast As Long
    
    Set sourceSheet = ThisWorkbook.Sheets("Import")
    Set destinationSheet = ThisWorkbook.Sheets("Sheet2")
    
    With Application
        rowFirst = .IfError(.Match("ID", sourceSheet.Columns("B"), 0), 0)
        If rowFirst = 0 Then Exit Sub
    End With
    
    With sourceSheet
        rowLast = .Cells.Find(What:="*", _
                        After:=.Range("A1"), _
                        LookAt:=xlPart, _
                        LookIn:=xlFormulas, _
                        SearchOrder:=xlByRows, _
                        SearchDirection:=xlPrevious, _
                        MatchCase:=False).Row
        Set sourceRng = .Range(.Cells(rowFirst, "B"), .Cells(rowLast, "E"))
    End With
    
    With destinationSheet
        destRowFirst = 13
        destRowLast = .Range("A" & .Rows.Count).End(xlUp).Row
        If destRowLast >= destRowFirst Then
            .Range(.Cells(destRowFirst, "A"), .Cells(destRowLast, "D")).ClearContents
        Else
            destRowLast = destRowFirst                  ' Not currently required
        End If
    End With
    
    
    With sourceRng
        If sourceSheet.FilterMode Then sourceSheet.ShowAllData
        .AutoFilter Field:=1, Criteria1:="<>"
        .Offset(1).Resize(.Rows.Count - 1).Copy
    End With
        
    With destinationSheet
        .Cells(destRowFirst, "A").PasteSpecial Paste:=xlPasteValues
        ' Release selection on paste range
        .Activate
        .Range("A1").Select
    End With
    
    sourceRng.AutoFilter
    Application.CutCopyMode = False

    If Evaluate("ISREF('" & "Import" & "'!A1)") Then
        Application.DisplayAlerts = False
        ThisWorkbook.Worksheets("Import").Delete
        Application.DisplayAlerts = True
    End If
    
End Sub
 
Upvote 0
Solution
See if this does what you need. You shouldn't need to do any manual manipulation.

VBA Code:
Sub ExtractData_v02()

    Dim sourceSheet As Worksheet
    Dim destinationSheet As Worksheet
    Dim rowFirst As Long, rowLast As Long
    Dim sourceRng As Range
    Dim destRowFirst As Long, destRowLast As Long
   
    Set sourceSheet = ThisWorkbook.Sheets("Import")
    Set destinationSheet = ThisWorkbook.Sheets("Sheet2")
   
    With Application
        rowFirst = .IfError(.Match("ID", sourceSheet.Columns("B"), 0), 0)
        If rowFirst = 0 Then Exit Sub
    End With
   
    With sourceSheet
        rowLast = .Cells.Find(What:="*", _
                        After:=.Range("A1"), _
                        LookAt:=xlPart, _
                        LookIn:=xlFormulas, _
                        SearchOrder:=xlByRows, _
                        SearchDirection:=xlPrevious, _
                        MatchCase:=False).Row
        Set sourceRng = .Range(.Cells(rowFirst, "B"), .Cells(rowLast, "E"))
    End With
   
    With destinationSheet
        destRowFirst = 13
        destRowLast = .Range("A" & .Rows.Count).End(xlUp).Row
        If destRowLast >= destRowFirst Then
            .Range(.Cells(destRowFirst, "A"), .Cells(destRowLast, "D")).ClearContents
        Else
            destRowLast = destRowFirst                  ' Not currently required
        End If
    End With
   
   
    With sourceRng
        If sourceSheet.FilterMode Then sourceSheet.ShowAllData
        .AutoFilter Field:=1, Criteria1:="<>"
        .Offset(1).Resize(.Rows.Count - 1).Copy
    End With
       
    With destinationSheet
        .Cells(destRowFirst, "A").PasteSpecial Paste:=xlPasteValues
        ' Release selection on paste range
        .Activate
        .Range("A1").Select
    End With
   
    sourceRng.AutoFilter
    Application.CutCopyMode = False

    If Evaluate("ISREF('" & "Import" & "'!A1)") Then
        Application.DisplayAlerts = False
        ThisWorkbook.Worksheets("Import").Delete
        Application.DisplayAlerts = True
    End If
   
End Sub
This works flawlessly!!! Thank you so much!!!

i wonder if you can help me on another code im working on?
 
Upvote 0

Forum statistics

Threads
1,226,220
Messages
6,189,697
Members
453,565
Latest member
Mukundan

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top