overzetten regels

[loods]

Mijn vraag over onderstaande macro is
Hoe kan ik nu een bereik in stellen zodat hij uit een sheet alle regels binnen haalt
En ook weer weg schrijft op regel niveau
Van 50 bestanden moet ik 1 bestand maken, ze worden in hetzelfde format aangeleverd maar wel ieder sheet met een ander naam

Sub Rechthoek1_Klikken()

Dim bestandopen As String, arr, cl As Range
Application.ScreenUpdating = False
bestandopen = Dir("K:\ict\test\*")
Do Until bestandopen = ""

If bestandopen = "" Then Exit Do
Workbooks.Open "K:\ict\test\" & bestandopen
With ActiveWorkbook.Sheets("test")
arr = Array()


For Each Row In .Range("A27:Q27")
If Row.Column <> 18 Then
ReDim Preserve arr(UBound(arr) + 1)
arr(UBound(arr)) = Row
End If
Next Row
ThisWorkbook.Sheets(1).Cells(Rows.Count, 1).End(xlUp).Offset(1).Resize(, 18) = arr

End With
Application.DisplayAlerts = False
Workbooks(bestandopen).Close False
bestandopen = Dir
Loop
Application.DisplayAlerts = True

Dim d As String, ext, x
Dim srcPath As String, destPath As String, srcFile As String
srcPath = "K:\ict\test\"
destPath = "K:\ict\test\test\"
ext = Array("*.xl*")
For Each x In ext
    d = Dir(srcPath & x)
        Do While d <> ""
            srcFile = srcPath & d
            FileCopy srcFile, destPath & d
            Kill srcFile
            d = Dir
        Loop
Next
   
End Sub

 

[loods]

vervolg

Ik heb onderstaande gevonden en het werkt
Allen vraag ik mij af wie kan mij helpen met alleen de waarde over te zetten zonder opmaak

Sub VoegExcelBestandenSamenIn1NieuwBlad()

Dim wbSingleWorkbook As Excel.Workbook, wbFinalWorkbook As Excel.Workbook
Dim wsSingleSheet As Excel.Worksheet, wsFinalSheet As Excel.Worksheet
Dim strPath As String, strWorkbook(500) As String ' max 500 bestanden
Dim intCounter As Integer, n As Integer
Dim Answer As VbMsgBoxResult

strPath = "K:\ict\test\" ' Map met .xls-bestanden
intCounter = 1 ' teller
strWorkbook(intCounter) = Dir(strPath & "*.xls")

Do While strWorkbook(intCounter) <> ""

intCounter = intCounter + 1
strWorkbook(intCounter) = Dir

Loop

intCounter = intCounter - 1 ' want de laatste is leeg
Set wbFinalWorkbook = Workbooks.Add
Application.DisplayAlerts = False

Do While wbFinalWorkbook.Sheets.Count > 1

wbFinalWorkbook.Sheets(1).Delete

Loop ' We hebben maar 1 blad nodig

Application.DisplayAlerts = True
Set wsFinalSheet = wbFinalWorkbook.Sheets(1)

On Error GoTo Einde ' Error trapping AAN

For n = 1 To intCounter

Set wbSingleWorkbook = Workbooks.Open(Filename:=strPath _
& strWorkbook(n), ReadOnly:=True)

For Each wsSingleSheet In wbSingleWorkbook.Sheets

wsSingleSheet.UsedRange.Copy _
Destination:=wsFinalSheet.Cells _
(wsFinalSheet.Cells.SpecialCells _
(xlCellTypeLastCell).Row + 1, 1)

Next wsSingleSheet

wbSingleWorkbook.Close

Next n

On Error GoTo 0 ' Error trapping UIT

Einde:

Select Case Err.Number ' Foutmelding 1004 is
' hoogstwaarschijnlijk veroorzaakt
Case 1004 ' door iets te plakken dat boven
' de 65536 rijen uit zou komen
Answer = MsgBox(Err.Description & Chr(13) & Chr(13) & _
"Waarschijnlijk wordt dit bestand te groot..." & _
Chr(13) & "Verder gaan op nieuw blad?", _
vbCritical Or vbYesNo, "Error " & Err.Number & _
": " & Err.Description)

If Answer = vbYes Then

Set wsFinalSheet = wbFinalWorkbook.Sheets.Add
Resume

End If

Case 0 ' Niks aan 't handje

Case Else ' Overige foutmeldingen

MsgBox Err.Description, _
vbCritical Or vbOKOnly, "Error " & Err.Number & _
" in bestand " & n

End Select

Set wbSingleWorkbook = Nothing
Set wbFinalWorkbook = Nothing
Set wsSingleSheet = Nothing
Set wsFinalSheet = Nothing

End Sub