Refactoring & issue with row

[nvnispen]

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 Sub

Private Sub Workbook_Open()
    ActiveWorkbook.Saved = True
    End Sub

Sub 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 Sub

Function 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

[p45cal]

For Each fil In CardFolder.Files
  If Left(fso.GetFileName(fil.Path), 2) = "In" Then
    Set IC = Workbooks.Open(fil.Path)
    With IC
      'Determine row:
      myRow = wbThis.Worksheets("Sheet3").Range("A500").End(xlUp).Offset(1, 0).Row
      wbThis.Worksheets("Sheet3").Cells(myRow, "A").Value = .Name
      'value1
      wbThis.Worksheets("Sheet3").Cells(myRow, "B").Value = .Sheets("Sheet1").Range("K10").Value
      'value2
      wbThis.Worksheets("Sheet3").Cells(myRow, "C").Value = .Sheets("Sheet1").Range("K11").Value
      'value 3
      wbThis.Worksheets("Sheet3").Cells(myRow, "D").Value = .Sheets("Sheet1").Range("K12").Value
            
      ' Repeat 59 times.
            
      Workbook_Open
     .Close

or:

For Each fil In CardFolder.Files
  If Left(fso.GetFileName(fil.Path), 2) = "In" Then
    Set IC = Workbooks.Open(fil.Path)
    With IC
      'Determine row:
      myRow = wbThis.Worksheets("Sheet3").Range("A500").End(xlUp).Offset(1, 0).Row
      wbThis.Worksheets("Sheet3").Cells(myRow, "A").Resize(, 4).Value = Array(.Name, .Sheets("Sheet1").Range("K10").Value, .Sheets("Sheet1").Range("K11").Value, .Sheets("Sheet1").Range("K12").Value)
           
      Workbook_Open
      .Close

or if the values don't contain dates you might get away with:

For Each fil In CardFolder.Files
  If Left(fso.GetFileName(fil.Path), 2) = "In" Then
    Set IC = Workbooks.Open(fil.Path)
    With IC
      'Determine row:
      myRow = wbThis.Worksheets("Sheet3").Range("A500").End(xlUp).Offset(1, 0).Row
      wbThis.Worksheets("Sheet3").Cells(myRow, "A").Value = .Name
      '3 values:
      wbThis.Worksheets("Sheet3").Cells(myRow, "B").Resize(, 3) = Application.Transpose(.Sheets("Sheet1").Range("K10").Resize(3).Value)
           
      Workbook_Open
      .Close

All untested.

[nvnispen]

Pascal,

Thank you very much. This is surely a welcome-back from holiday gift. The first two codes work like a charm, since there are dates involved I skipped the third option.

Nick