Copy text

KlausW

Board Regular
Joined
Sep 9, 2020
Messages
159
Office Version
  1. 2016
Platform
  1. Windows
Hi Excel helpers
, with this VBA code, I import image from a tab in an Excel file, to a Tab in another Excel file. It just works.
What I liked was that Excel can also import text. From the same tab The cells I would like Excel to import are F3: L18. Inserted in F3.
All help will be appreciated.
Regards KW

VBA Code:
Sub Knap6_Klik()

'

' Import fra fil

'

If TypeName(Selection) <> "Range" Then Exit Sub

Dim i As Long

Dim vRegions As Variant

Dim rngRegions() As Excel.Range

Dim rngSourceRange As Excel.Range

Dim rngDestination As Excel.Range

Dim wkbCrntWorkBook As Workbook

Dim wkbSourceBook As Workbook

Dim DestWorkbook As String

Dim DestSheet As String

Dim Deling As Integer





DestWorkbook = ActiveWorkbook.Name

DestSheet = ActiveSheet.Name



Set rngDestination = Application.InputBox(prompt:="Specify the upper left cell for the paste range:", _

Title:="Select Destination", Default:="a2", Type:=8)



With Application.FileDialog(msoFileDialogOpen)

.Filters.Clear

.AllowMultiSelect = False

.Show

If .SelectedItems.Count > 0 Then

Workbooks.Open .SelectedItems(1)

Set wkbSourceBook = ActiveWorkbook

End If

End With



Deling = Application.InputBox(prompt:="Select Deling", _

Title:="Source Deling", Default:="1", Type:=1)

Sheets("Billeder " & Deling & ".deling").Select



Set rngSourceRange = Application.InputBox(prompt:="Select source range", _

Title:="Source Range", Default:="a3:d3;a7:d7;a11:d11;a15:d15", Type:=8)

rngSourceRange.Select



vRegions = Split(Selection.Address, ",")



ReDim rngRegions(LBound(vRegions) To UBound(vRegions))



For i = LBound(vRegions) To UBound(vRegions)

Set rngRegions(i) = Range(vRegions(i))

rngRegions(i).Copy _

Destination:=Workbooks(DestWorkbook).Worksheets(DestSheet).Range("a2") _

.Offset(rngRegions(i).Row - rngRegions(LBound(rngRegions)).Row, _

rngRegions(i).Column - rngRegions(LBound(rngRegions)).Column)

Next i

wkbSourceBook.Close False





End Sub
 

Excel Facts

Easy bullets in Excel
If you have a numeric keypad, press Alt+7 on numeric keypad to type a bullet in Excel.

KlausW

Board Regular
Joined
Sep 9, 2020
Messages
159
Office Version
  1. 2016
Platform
  1. Windows
Found the solution myself KW
 

KlausW

Board Regular
Joined
Sep 9, 2020
Messages
159
Office Version
  1. 2016
Platform
  1. Windows
Glad to hear you got found the solution!

Do you mind posting your solution? Then it is perfectly fine to mark it as the solution to help future readers.

Thanks.
Hello, and Merry Christmas. I use this VBA code to import a sheet into my Excel file. And then I indirectly to transfer the data to the sheet I need to use them. Then I use this VBA code to transfer the images from the same sheet. I would have liked to be able to merge the 2 VBA codes. KW

VBA Code:
Sub Rektangelafrundedehjørner1_Klik()

Dim ws As Worksheet
   Dim Wbk As Workbook
   Dim Pth As String, Fname As String, ShtName As String
      Pth = GetFolder()
      Fname = Dir(Pth & "\*.xlsm")
      ShtName = LCase(Sheets("Billeder").Range("j1").Text)
   
   Do While Fname <> ""
     Set Wbk = Workbooks.Open(Pth & "\" & Fname)
      For Each ws In Wbk.Worksheets
         If LCase(ws.Name) = ShtName Then
            ws.Copy , ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
         End If
      Next ws
      Wbk.Close False
      Fname = Dir
   Loop
   
End Sub
VBA Code:
Function GetFolder() As String
Dim dlg As FileDialog
Set dlg = Application.FileDialog(msoFileDialogFolderPicker)
'dlg.InitialFileName = "c:\"
'If dlg.Show = -1 Then
'GetFolder = dlg.SelectedItems(1)
'End If
With dlg

    .InitialFileName = "d:\"
    .Show
    GetFolder = .SelectedItems(1)
   
End With

End Function
[CODE=vba]
Sub Rektangelafrundedehjørner2_Klik()
'
' Import fra fil
'
If TypeName(Selection) <> "Range" Then Exit Sub
    Dim i As Long
    Dim vRegions As Variant
    Dim rngRegions() As Excel.Range
    Dim rngSourceRange As Excel.Range
    Dim rngDestination As Excel.Range
    Dim wkbCrntWorkBook As Workbook
    Dim wkbSourceBook As Workbook
    Dim DestWorkbook As String
    Dim DestSheet As String
    Dim Deling As Integer
   
   
    DestWorkbook = ActiveWorkbook.Name
    DestSheet = ActiveSheet.Name
   
      Set rngDestination = Application.InputBox(prompt:="Specify the upper left cell for the paste range:", _
  Title:="Select Destination", Default:="a2", Type:=8)
   
  With Application.FileDialog(msoFileDialogOpen)
        .Filters.Clear
        .AllowMultiSelect = False
        .Show
        If .SelectedItems.Count > 0 Then
            Workbooks.Open .SelectedItems(1)
    Set wkbSourceBook = ActiveWorkbook
        End If
    End With
   
    Deling = Application.InputBox(prompt:="Select Deling", _
    Title:="Source Deling", Default:="1", Type:=1)
      Sheets("Billeder " & Deling & ".deling").Select

  Set rngSourceRange = Application.InputBox(prompt:="Select source range", _
  Title:="Source Range", Default:="a3:d3;a7:d7;a11:d11;a15:d15", Type:=8)
  rngSourceRange.Select

    vRegions = Split(Selection.Address, ",")
   
    ReDim rngRegions(LBound(vRegions) To UBound(vRegions))
   
  For i = LBound(vRegions) To UBound(vRegions)
    Set rngRegions(i) = Range(vRegions(i))
    rngRegions(i).Copy _
        Destination:=Workbooks(DestWorkbook).Worksheets(DestSheet).Range("a2") _
        .Offset(rngRegions(i).Row - rngRegions(LBound(rngRegions)).Row, _
              rngRegions(i).Column - rngRegions(LBound(rngRegions)).Column)
  Next i
  wkbSourceBook.Close False

End Sub
 
Solution

Forum statistics

Threads
1,143,620
Messages
5,719,788
Members
422,244
Latest member
AYSHANA

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
Top