Celwaarde uit gesloten bestand plakken in open bestand

[JKettelarij]

Hallo,

Kan iemand mij uitleggen hoe ik in VBA een range cellen uit een gesloten werkblad kan knippen en die plakken in het bestand dat ik open heb staan.

Via onderstaande code importeer ik tekst maar nu zou ik graag een range (c7:F267) willen importeren.


Sub Import()
'
Application.ScreenUpdating = False


Dim VolledigeNaam As String
VolledigeNaam = Application.GetOpenFilename("Alle bestanden (*.CLC), *.*", Title:="Selecteer het bestand om te importeren")

Sheets("Import").Select
Rows("2:2400").Select
Selection.ClearContents

On Error GoTo einde

With ActiveSheet.QueryTables.Add(Connection:= _
"TEXT;" & VolledigeNaam, Destination:=Range("$A$2"))
.Name = "12-086-4-8-11"
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.TextFilePromptOnRefresh = False
.TextFilePlatform = 1252
.TextFileStartRow = 1
.TextFileParseType = xlDelimited
.TextFileTextQualifier = xlTextQualifierDoubleQuote
.TextFileConsecutiveDelimiter = True
.TextFileTabDelimiter = True
.TextFileSemicolonDelimiter = True
.TextFileCommaDelimiter = True
.TextFileSpaceDelimiter = False
.TextFileOtherDelimiter = "'"
.TextFileColumnDataTypes = Array(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 2)
.TextFileTrailingMinusNumbers = True
.Refresh BackgroundQuery:=False
End With
Rows("2:2400").Select
Selection.Replace What:=" ", Replacement:="-", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False

Cells.Select
Cells.EntireColumn.AutoFit

Het bestandje waaruit ik dit wil doen is iedere keer een andere.

Alvast bedankt.

M.Vr.Gr J Kettelarij

 

[spaarie]

Zoiets?

Sub Spaarie()
    bestand = Application.GetOpenFilename("CLC Bestanden, *.clc", , "Selecteer bestand")
    If bestand = False Then
        MsgBox "U heeft geen bestand gekozen.", vbCritical, "Fout"
        Exit Sub
    End If
    Workbooks.Open (bestand)
    With Sheets.Add
        .Name = "TEMP"
        With .QueryTables.Add("TEXT;" & bestand, .Range("$A$2"))
            .Name = "12-086-4-8-11"
            .FieldNames = True
            .RowNumbers = False
            .FillAdjacentFormulas = False
            .PreserveFormatting = True
            .RefreshOnFileOpen = False
            .RefreshStyle = xlInsertDeleteCells
            .SavePassword = False
            .SaveData = True
            .AdjustColumnWidth = True
            .RefreshPeriod = 0
            .TextFilePromptOnRefresh = False
            .TextFilePlatform = 1252
            .TextFileStartRow = 1
            .TextFileParseType = xlDelimited
            .TextFileTextQualifier = xlTextQualifierDoubleQuote
            .TextFileConsecutiveDelimiter = True
            .TextFileTabDelimiter = True
            .TextFileSemicolonDelimiter = True
            .TextFileCommaDelimiter = True
            .TextFileSpaceDelimiter = False
            .TextFileOtherDelimiter = "'"
            .TextFileColumnDataTypes = Array(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 2)
            .TextFileTrailingMinusNumbers = True
            .Refresh BackgroundQuery:=False
        End With
        .UsedRange.Replace " ", "-"
        .Columns.AutoFit
        .Range("C7:F267").Copy Sheets("Import").Cells(2, 1)
    End With
    Application.DisplayAlerts = False
    Sheets("TEMP").Delete
    Application.DisplayAlerts = True
End Sub

 

[JKettelarij]

Hallo Spaarie,

Bedankt voor je reactie,

De bron is een xlsm bestand en geen text.
Als ik de .clc verander in .xlsm van worden er vreemde tekens geimporteerd omdat het xlsm is.

Dus de querytable.add text is in deze code niet goed.
het zal iets anders zijn om cellen met waardes te kunnen ophalen.

M.Vr.Gr Jkettelarij

 

[spaarie]

Waar in de vraag moet ik opmaken dat het om een .xlsm bestand gaat?
En om welk blad gaat het dan uit je .xlsm bestand?

 

[JKettelarij]

Blad "Leverschema"

 

[spaarie]

Sub Spaarie()
    bestand = Application.GetOpenFilename("Excel Files, *.xls; *.xlsx; *.xlsm", , "Selecteer bestand")
    If bestand = False Then
        MsgBox "U heeft geen bestand gekozen.", vbCritical, "Fout"
        Exit Sub
    End If
    Workbooks.Open (bestand)
    ActiveWorkbook.Sheets("Leverschema").Range("C7:F267").Copy ThisWorkbook.Sheets("Import").Cells(2, 1)
    ActiveWorkbook.Close False
End Sub

 

[JKettelarij]

Hej spaarie,

Hartstikke bedankt, het lukt, ik kan weer verder