Attempting importing sheet from data file into destination file.

[LZ_Code]

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 - Import Workbook/Choose Sheet/Display Details

Hello, This was a follow-on question related to another thread here on the board. At the recommendation of the board (the original question is more than 1400 days old), as well as the original solution giver, I am posting this with some of my own directed details. I am trying to do a mixture...

www.mrexcel.com

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

 

[LZ_Code]

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.

 

[LZ_Code]

Thank you for your help I appreciate it so much!

 

[Alex Blakenburg]

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.

 

[LZ_Code]

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.

yes please!

 

[Alex Blakenburg]

See if this does what you need. You shouldn't need to do any manual manipulation.

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

 

[LZ_Code]

See if this does what you need. You shouldn't need to do any manual manipulation.

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?

Trying to get the "Name of Panel" User puts in sheet "TOC" cell A:27, and gets only the 'SQL Query to import Analog Input Tags the user is filtering.

Here is the code im working with. Need to figure out how to add code that will look for the "Name of Panel" and filter out the Analog inputs. Option Explicit Sub AnalogInput_DB() 'Path Dim strPath As String 'Provider Dim strProv As String 'Connection String...

www.mrexcel.com

 

[Alex Blakenburg]

Thanks for letting me know. Glad I could help.