need a processional look at my challenge

[mike8791]

I would like some help on this Task. I'm doing this for work. I would like a VBA code that if it runs:
1- It promote a box asking to open a workbook. 2- in the opened workbook i would like to copy then transpose a range values to the "vba workbook i.e. the original one opened".
3- It asks then where do you want to paste them however all data should create one long column.


i have found this code but i feel it needs a professional look at:



Sub tanspseandcopyfromopenoptionworkbook()
Dim xRng As Range
Dim Xnew As Range
Dim i As Integer
Dim xLastRow As Integer
Dim xTxt As String
Dim FileToOpen As Variant
Dim OpenBook As Workbook
On Error Resume Next

' open file
FileToOpen = Application.GetOpenFilename(Title:="Browse for your File & Import Range", FileFilter:="Excel Files (*.xls*),*xls*")
If FileToOpen <> False Then
Set OpenBook = Application.Workbooks.Open(FileToOpen)
End If
' open file
On Error Resume Next
xTxt = Application.ActiveWindow.RangeSelction.Address
Set Xnew = Application.InputBox("select data range", "Kutools", xTxt, , , , , 8)
If Xnew Is Nothing Then Exit Sub



xLastRow = Xnew.Columns(i).Rows.Count + 1
For i = 2 To Xnew.Columns.Count
Range(Xnew.Cells(1, i), Xnew.Cells(Xnew.Columns(i).Rows.Count, i)).Cut

ActiveSheet.Paste Destination:=Xnew.Cells(xLastRow, 1)
xLastRow = xLastRow + Xnew.Columns(i).Rows.Count
Next
'PasteSpecial_Examples (Xnew)
End Sub







Sub PasteSpecial_Examples()
Workbooks("Testing.xlsm").Worksheets("Sheet1").Range("D3:N14").Copy
ActiveSheet.Range("C26").PasteSpecial Transpose:=True
End Sub

 

[mike8791]

Essentially, the second code you have provided is just missing to make the output as one Column. It does copy the data and transpose them. However, missing the last step i wish i have which is arranging the "Copied & Transposed" data in a one long Column. I wish i made myself clear here.

 

[mumps]

Try:

Sub CopyRange()
    Dim flder As FileDialog, FileName As String, FileChosen As Integer, srcWB As Workbook, desWS As Worksheet, cnt As Long
    Dim copyRng As Range, desCol As String, i As Long, x As Long
    Set desWS = ThisWorkbook.Sheets("Sheet1")
    Set flder = Application.FileDialog(msoFileDialogFilePicker)
    flder.Title = "Please Select a Excel Macro File"
    FileChosen = flder.Show
    FileName = flder.SelectedItems(1)
    Set srcWB = Workbooks.Open(FileName)
    Set copyRng = Application.InputBox(Prompt:="Select a range to copy.", Title:="Range Selection", Type:=8)
    Application.ScreenUpdating = False
    cnt = copyRng.Columns(i).Cells.Count
    desCol = InputBox("Enter the column letter where you want to paste.")
    If desCol = "" Then Exit Sub
    x = Cells(1, desCol).Column
    For i = 1 To copyRng.Columns.Count
        With desWS
            copyRng.Cells(1, i).Resize(cnt).Copy
            .Cells(.Rows.Count, desCol).End(xlUp).Offset(1).PasteSpecial Transpose:=True
        End With
    Next i
    For i = 1 To cnt
        With desWS
            .Cells(2, x).Resize(copyRng.Columns.Count).Copy .Cells(.Rows.Count, desCol).End(xlUp).Offset(1)
            x = x + 1
        End With
    Next i
    desWS.Rows(copyRng.Columns.Count + 2).Insert
    ActiveWorkbook.Close False
    Application.ScreenUpdating = True
End Sub

 

[mike8791]

Try:

Sub CopyRange()
    Dim flder As FileDialog, FileName As String, FileChosen As Integer, srcWB As Workbook, desWS As Worksheet, cnt As Long
    Dim copyRng As Range, desCol As String, i As Long, x As Long
    Set desWS = ThisWorkbook.Sheets("Sheet1")
    Set flder = Application.FileDialog(msoFileDialogFilePicker)
    flder.Title = "Please Select a Excel Macro File"
    FileChosen = flder.Show
    FileName = flder.SelectedItems(1)
    Set srcWB = Workbooks.Open(FileName)
    Set copyRng = Application.InputBox(Prompt:="Select a range to copy.", Title:="Range Selection", Type:=8)
    Application.ScreenUpdating = False
    cnt = copyRng.Columns(i).Cells.Count
    desCol = InputBox("Enter the column letter where you want to paste.")
    If desCol = "" Then Exit Sub
    x = Cells(1, desCol).Column
    For i = 1 To copyRng.Columns.Count
        With desWS
            copyRng.Cells(1, i).Resize(cnt).Copy
            .Cells(.Rows.Count, desCol).End(xlUp).Offset(1).PasteSpecial Transpose:=True
        End With
    Next i
    For i = 1 To cnt
        With desWS
            .Cells(2, x).Resize(copyRng.Columns.Count).Copy .Cells(.Rows.Count, desCol).End(xlUp).Offset(1)
            x = x + 1
        End With
    Next i
    desWS.Rows(copyRng.Columns.Count + 2).Insert
    ActiveWorkbook.Close False
    Application.ScreenUpdating = True
End Sub

This is great but one last comment hahahahahaha.


Please check the file i share.

MrMumps.xlsm

 

[mumps]

Try:

Sub CopyRange()
    Dim flder As FileDialog, FileName As String, FileChosen As Integer, srcWB As Workbook, desWS As Worksheet, cnt As Long
    Dim copyRng As Range, desCol As String, i As Long, x As Long
    Set desWS = ThisWorkbook.Sheets("Sheet1")
    Set flder = Application.FileDialog(msoFileDialogFilePicker)
    flder.Title = "Please Select a Excel Macro File"
    FileChosen = flder.Show
    FileName = flder.SelectedItems(1)
    Set srcWB = Workbooks.Open(FileName)
    Set copyRng = Application.InputBox(Prompt:="Select a range to copy.", Title:="Range Selection", Type:=8)
    Application.ScreenUpdating = False
    cnt = copyRng.Columns(i).Cells.Count
    desCol = InputBox("Enter the column letter where you want to paste.")
    If desCol = "" Then Exit Sub
    x = Cells(1, desCol).Column
    For i = 1 To copyRng.Columns.Count
        With desWS
            copyRng.Cells(1, i).Resize(cnt).Copy
            .Cells(.Rows.Count, desCol).End(xlUp).Offset(1).PasteSpecial Transpose:=True
        End With
    Next i
    For i = 1 To cnt
        With desWS
            .Cells(2, x).Resize(copyRng.Columns.Count).Copy .Cells(.Rows.Count, desCol).End(xlUp).Offset(1)
            x = x + 1
        End With
    Next i
    desWS.Rows("1:" & copyRng.Columns.Count + 1).Delete
    ActiveWorkbook.Close False
    Application.ScreenUpdating = True
End Sub

 

[mike8791]

Thank you for your enormous effort. One Last comment please and you made my day. Kindly check the file shared.
MrMumps_last

 

[mumps]

Change the number 17 (in red) to the row number where you want the paste to start.

Sub CopyRange()
    Dim flder As FileDialog, FileName As String, FileChosen As Integer, srcWB As Workbook, desWS As Worksheet, cnt As Long
    Dim copyRng As Range, desCol As String, i As Long, x As Long
    Set desWS = ThisWorkbook.Sheets("Sheet1")
    Set flder = Application.FileDialog(msoFileDialogFilePicker)
    flder.Title = "Please Select an Excel File"
    FileChosen = flder.Show
    FileName = flder.SelectedItems(1)
    Set srcWB = Workbooks.Open(FileName)
    Set copyRng = Application.InputBox(Prompt:="Select a range to copy.", Title:="Range Selection", Type:=8)
    Application.ScreenUpdating = False
    cnt = copyRng.Columns.Count
    desCol = InputBox("Enter the column letter where you want to paste.")
    If desCol = "" Then Exit Sub
    For i = 1 To copyRng.Rows.Count
        With desWS
            x = .Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
            If x < 17 Then
                .Cells(17, desCol).Resize(cnt) = WorksheetFunction.Transpose(copyRng.Cells(i, 1).Resize(, cnt))
            Else
                .Cells(.Rows.Count, desCol).End(xlUp).Offset(1).Resize(cnt) = WorksheetFunction.Transpose(copyRng.Cells(i, 1).Resize(, cnt))
            End If
        End With
    Next i
    ActiveWorkbook.Close False
    Application.ScreenUpdating = True
End Sub

 

[mike8791]

Change the number 17 (in red) to the row number where you want the paste to start.

Sub CopyRange()
    Dim flder As FileDialog, FileName As String, FileChosen As Integer, srcWB As Workbook, desWS As Worksheet, cnt As Long
    Dim copyRng As Range, desCol As String, i As Long, x As Long
    Set desWS = ThisWorkbook.Sheets("Sheet1")
    Set flder = Application.FileDialog(msoFileDialogFilePicker)
    flder.Title = "Please Select an Excel File"
    FileChosen = flder.Show
    FileName = flder.SelectedItems(1)
    Set srcWB = Workbooks.Open(FileName)
    Set copyRng = Application.InputBox(Prompt:="Select a range to copy.", Title:="Range Selection", Type:=8)
    Application.ScreenUpdating = False
    cnt = copyRng.Columns.Count
    desCol = InputBox("Enter the column letter where you want to paste.")
    If desCol = "" Then Exit Sub
    For i = 1 To copyRng.Rows.Count
        With desWS
            x = .Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
            If x < 17 Then
                .Cells(17, desCol).Resize(cnt) = WorksheetFunction.Transpose(copyRng.Cells(i, 1).Resize(, cnt))
            Else
                .Cells(.Rows.Count, desCol).End(xlUp).Offset(1).Resize(cnt) = WorksheetFunction.Transpose(copyRng.Cells(i, 1).Resize(, cnt))
            End If
        End With
    Next i
    ActiveWorkbook.Close False
    Application.ScreenUpdating = True
End Sub

the code gives an error Run-time error '91' : Object variable or with block variable not set
it highlight the yellow part of the code


Sub CopyRange()
Dim flder As FileDialog, FileName As String, FileChosen As Integer, srcWB As Workbook, desWS As Worksheet, cnt As Long
Dim copyRng As Range, desCol As String, i As Long, x As Long
Set desWS = ThisWorkbook.Sheets("Sheet1")
Set flder = Application.FileDialog(msoFileDialogFilePicker)
flder.Title = "Please Select an Excel File"
FileChosen = flder.Show
FileName = flder.SelectedItems(1)
Set srcWB = Workbooks.Open(FileName)
Set copyRng = Application.InputBox(Prompt:="Select a range to copy.", Title:="Range Selection", Type:=8)
Application.ScreenUpdating = False
cnt = copyRng.Columns.Count
desCol = InputBox("Enter the column letter where you want to paste.")
If desCol = "" Then Exit Sub
For i = 1 To copyRng.Rows.Count
With desWS
x = .Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
If x < 17 Then
.Cells(17, desCol).Resize(cnt) = WorksheetFunction.Transpose(copyRng.Cells(i, 1).Resize(, cnt))
Else
.Cells(.Rows.Count, desCol).End(xlUp).Offset(1).Resize(cnt) = WorksheetFunction.Transpose(copyRng.Cells(i, 1).Resize(, cnt))
End If
End With
Next i
ActiveWorkbook.Close False
Application.ScreenUpdating = True
End Sub

 

[mike8791]

I have tried to move the yellow part of the code inside the if statement it works just fine. I'm not sure if this is the right way of fixing it.

 

[mumps]

Try:

Sub CopyRange()
    Dim flder As FileDialog, FileName As String, FileChosen As Integer, srcWB As Workbook, desWS As Worksheet, cnt As Long
    Dim copyRng As Range, desCol As String, i As Long, x As Long
    Set desWS = ThisWorkbook.Sheets("Sheet1")
    Set flder = Application.FileDialog(msoFileDialogFilePicker)
    flder.Title = "Please Select an Excel File"
    FileChosen = flder.Show
    FileName = flder.SelectedItems(1)
    Set srcWB = Workbooks.Open(FileName)
    Set copyRng = Application.InputBox(Prompt:="Select a range to copy.", Title:="Range Selection", Type:=8)
    Application.ScreenUpdating = False
    cnt = copyRng.Columns.Count
    desCol = InputBox("Enter the column letter where you want to paste.")
    If desCol = "" Then Exit Sub
    For i = 1 To copyRng.Rows.Count
        With desWS
            If WorksheetFunction.CountA(.UsedRange) = 0 Then
                .Cells(17, desCol).Resize(cnt) = WorksheetFunction.Transpose(copyRng.Cells(i, 1).Resize(, cnt))
            Else
                .Cells(.Rows.Count, desCol).End(xlUp).Offset(1).Resize(cnt) = WorksheetFunction.Transpose(copyRng.Cells(i, 1).Resize(, cnt))
            End If
        End With
    Next i
    ActiveWorkbook.Close False
    Application.ScreenUpdating = True
End Sub

 

[mike8791]

Try:

Sub CopyRange()
    Dim flder As FileDialog, FileName As String, FileChosen As Integer, srcWB As Workbook, desWS As Worksheet, cnt As Long
    Dim copyRng As Range, desCol As String, i As Long, x As Long
    Set desWS = ThisWorkbook.Sheets("Sheet1")
    Set flder = Application.FileDialog(msoFileDialogFilePicker)
    flder.Title = "Please Select an Excel File"
    FileChosen = flder.Show
    FileName = flder.SelectedItems(1)
    Set srcWB = Workbooks.Open(FileName)
    Set copyRng = Application.InputBox(Prompt:="Select a range to copy.", Title:="Range Selection", Type:=8)
    Application.ScreenUpdating = False
    cnt = copyRng.Columns.Count
    desCol = InputBox("Enter the column letter where you want to paste.")
    If desCol = "" Then Exit Sub
    For i = 1 To copyRng.Rows.Count
        With desWS
            If WorksheetFunction.CountA(.UsedRange) = 0 Then
                .Cells(17, desCol).Resize(cnt) = WorksheetFunction.Transpose(copyRng.Cells(i, 1).Resize(, cnt))
            Else
                .Cells(.Rows.Count, desCol).End(xlUp).Offset(1).Resize(cnt) = WorksheetFunction.Transpose(copyRng.Cells(i, 1).Resize(, cnt))
            End If
        End With
    Next i
    ActiveWorkbook.Close False
    Application.ScreenUpdating = True
End Sub

Thank you So much you have really made it. I appreciate every second you have given helping me through this challenge. Thank you Tones and Millions

mumps ​