need a processional look at my challenge

M

mike8791

New Member
Joined
Mar 24, 2022
Messages
14
Office Version
  1. 2019
  2. 2016
Platform
  1. Windows
  2. Web
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
 
Sort by date Sort by votes
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.
 
Upvote 0

Excel Facts

Save Often
If you start asking yourself if now is a good time to save your Excel workbook, the answer is Yes
Try:
VBA 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 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
 
Upvote 0
mumps said:
Try:
VBA 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 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
Click to expand...
This is great but one last comment hahahahahaha.


Please check the file i share.

MrMumps.xlsm
 
Upvote 0
Try:
VBA 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 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
 
Upvote 0
Thank you for your enormous effort. One Last comment please and you made my day. Kindly check the file shared.
MrMumps_last
 
Upvote 0
Change the number 17 (in red) to the row number where you want the paste to start.
Rich (BB 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
 
Upvote 0
mumps said:
Change the number 17 (in red) to the row number where you want the paste to start.
Rich (BB 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
Click to expand...
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
 
Upvote 0
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.
 
Upvote 0
Try:
VBA 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
            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
 
Upvote 0
mumps said:
Try:
VBA 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
            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
Click to expand...

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 :)​

 
Upvote 0
You must log in or register to reply here.

Similar threads

SandsB
  • Question
Why does "Step Into" stop after I open my input file?
Replies
4
Views
282
SandsB
SandsB
R
  • Question
Copying data to an open file sheet from another
Replies
2
Views
487
rneilson52
R
B
  • Solved
Excel Macro Copy from one worksheet and paste to other worksheet and sort the data pasted.
Replies
9
Views
452
MayraBotla
M
L
  • Solved
Importing data from one excel workbook to another
Replies
2
Views
505
londa_vba
L
T
  • Solved
Block If without End If
2
Replies
13
Views
648
kevin9999
K

Forum statistics

Threads
1,214,789
Messages
6,121,605
Members
449,038
Latest member
Arbind kumar

Share this page

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