nvnispen
10-08-2018, 06:20 AM
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
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