Copy text

[KlausW]

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

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

 

[KlausW]

Found the solution myself KW

 

[smozgur]

Found the solution myself KW

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.

 

[KlausW]

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

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

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