PDA

View Full Version : [SOLVED] Refactoring & issue with row



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

p45cal
10-08-2018, 07:40 AM
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
.Closeor 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
.CloseAll untested.

nvnispen
10-15-2018, 02:14 AM
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