Dear community,
Another question, and I think both can be related to each other. I wrote a function that selects a multitude of relevant cells, in total 62, and copies them in a master file. Question 1: Is it possible to refactor this, I have tried it with different approaches: union, join, select every value at once, but none of them resulted in a working function.
Question 2: Currently it is assumed that every cell has a value, if so there is no problem with copying. However, I do not like assumptions and want to be prepared for blank cells. In the current situation if there is a blank, the next file will fill the gaps of the previous file. As you can imagine I want all the values on 1 row, representing the correct document. I have tried working with the pre-built function find, unfortunately without success. Does someone has any inspiration or workarounds for me? The remainder of my trial on find can be found below.
Your input will be very much appreciated.
Nick
Sub Button1_Click() Dim consolidateData As Workbook Dim wbThis As Workbook Dim IC As Workbook Dim fileName As String Dim consolidatePath As String Dim CardPath As String Dim fso As Scripting.FileSystemObject Dim fil As Scripting.file Dim CardFolder As Scripting.Folder consolidatePath = "C:\Desktop\Excel environment\Consolidate Cards.xlsm" CardPath = "C:\\Desktop\Excel environment\Cards" Set fso = New Scripting.FileSystemObject Set CardFolder = fso.GetFolder(CardPath) Set wbThis = ThisWorkbook For Each fil In CardFolder.Files If Left(fso.GetFileName(fil.path), 2) = "In" Then Set IC = Workbooks.Open(fil.path) With IC 'Filename fileName = IC.Name wbThis.Worksheets("Sheet3").Range("A500").End(xlUp).Offset(1, 0).Value = fileName 'value1 IC.Sheets("Sheet1").Range("K10").Select Selection.Copy wbThis.Worksheets("Sheet3").Range("B500").End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues 'value2 IC.Sheets("Sheet1").Range("K11").Select Selection.Copy wbThis.Worksheets("Sheet3").Range("C500").End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues 'value 3 IC.Sheets("Sheet1").Range("K12").Select Selection.Copy wbThis.Worksheets("Sheet3").Range("D500").End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues Repeat 59 times. Workbook_Open IC.Close Call MoveFiles(fileName) Application.Wait (Now + TimeValue("00:00:02")) End With End If Next fil Set fso = Nothing End SubPrivate Sub Workbook_Open() ActiveWorkbook.Saved = True End SubSub MoveFiles(path As String) Dim fso, destinationFolder, file As Scripting.FileSystemObject Dim objFolder As Scripting.Folder Dim sourceFilePath, entireSourcePath As String Dim destinationFolderPath As String 'gebruik deze sourceFilePath = "C:\Desktop\Excel environment\Cards\" entireSourcePath = (sourceFilePath & path) destinationFolderPath = "C:\Desktop\Excel environment\IC's done\" Set fso = New Scripting.FileSystemObject If fso.FileExists(entireSourcePath) = False Then MsgBox entireSourcePath & " does not exists 1." Exit Sub End If If fso.FolderExists(destinationFolderPath) = False Then MsgBox destinationFolderPath & " does not exists 2." Exit Sub End If fso.MoveFile Source:=entireSourcePath, Destination:=destinationFolderPath Set fso = Nothing End SubFunction LastRow() Dim lRow As Long 'if you find anything in a cell, stop. 'start after cell A1. On Error Resume Next lRow = Cells.Find(What:="*", _ After:=Range("A1"), _ LookIn:=xlFormulas, _ LookAt:=xlPart, _ SearchDirection:=xlPrevious, _ MatchCase:=False).Row On Error GoTo 0 Debug.Print lRow End Function