Code:
Sub Raghavendra2b() 'http://www.excelfox.com/forum/showthread.php/2238-Copy-data-from-Unique-files-into-Masterfile-all-the-files-in-the-same-folder?p=10575#post10575
Dim LisWb As Workbook
Set LisWb = ThisWorkbook
Dim Ws2 As Worksheet, Ws1 As Worksheet
Set Ws2 = LisWb.Worksheets.Item(2): Set Ws1 = LisWb.Worksheets.Item(1):
Dim strWb As String: Let strWb = Dir(ThisWorkbook.Path & "\" & "*" & ".xlsx", vbNormal)
Do ' Loop through all .xlsx Files in same Folder as this workbook
Workbooks.Open Filename:=ThisWorkbook.Path & Application.PathSeparator & strWb
Let Ws2.Range("A2:A1000").Value = "=" & "'" & ThisWorkbook.Path & "\[" & strWb & "]Sheet1'!$A2"
Dim Lr As Long
Let Lr = Ws2.Range("A2:A1000").Find(what:=0, after:=Ws2.Range("A2"), LookIn:=xlValues, lookat:=xlWhole, searchorder:=xlByRows, searchdirection:=xlNext).Row - 1
Let Ws1.Range("G" & Ws2.Range("A2").Value + 1 & ":L" & Ws2.Range("A" & Lr & "").Value + 1 & "").Value = "=" & "'" & ThisWorkbook.Path & "\[" & strWb & "]Sheet1'!G2"
Let Ws1.Range("G" & Ws2.Range("A2").Value + 1 & ":L" & Ws2.Range("A" & Lr & "").Value + 1 & "").Value = Ws1.Evaluate("=IF(ISERR(" & Ws1.Range("G" & Ws2.Range("A2").Value + 1 & ":L" & Ws2.Range("A" & Lr & "").Value + 1 & "").Address & ")," & """""" & ",IF(" & Ws1.Range("G" & Ws2.Range("A2").Value + 1 & ":L" & Ws2.Range("A" & Lr & "").Value + 1 & "").Address & "=0," & """""" & "," & Ws1.Range("G" & Ws2.Range("A2").Value + 1 & ":L" & Ws2.Range("A" & Lr & "").Value + 1 & "").Address & "))")
'Let Ws1.Range("G" & Ws2.Range("A2").Value + 1 & ":L" & Ws2.Range("A" & Lr & "").Value + 1 & "").Value = Evaluate("=IF(ISERR(" & Ws1.Range("G" & Ws2.Range("A2").Value + 1 & ":L" & Ws2.Range("A" & Lr & "").Value + 1 & "").Address & ")," & Empty & ",IF(" & Ws1.Range("G" & Ws2.Range("A2").Value + 1 & ":L" & Ws2.Range("A" & Lr & "").Value + 1 & "").Address & "=0," & Empty & "," & Ws1.Range("G" & Ws2.Range("A2").Value + 1 & ":L" & Ws2.Range("A" & Lr & "").Value + 1 & "").Address & "))") ' Does not remove the 0s ??
Let Ws1.Range("K" & Ws2.Range("A2").Value + 1 & ":L" & Ws2.Range("A" & Lr & "").Value + 1 & "").NumberFormat = "d.mmm yy"
Let Ws1.Range("K" & Ws2.Range("A2").Value + 1 & ":K" & Ws2.Range("A" & Lr & "").Value + 1 & "").SpecialCells(xlCellTypeConstants, xlNumbers).Offset(, 1).Value = Format(Date, "dd mmm yyyy") ' Put current date in cells 1 column to the left of cells in K column that have dates in
Let Workbooks("" & strWb & "").Worksheets.Item(1).Range("L2:L" & Lr & "").Value = Ws1.Range("L" & Ws2.Range("A2").Value + 1 & ":L" & Ws2.Range("A" & Lr & "").Value + 1 & "").Value ' Date values pasted in in last code line are given to correspondin cells in current open data workbook, first worksheet
Let Workbooks("" & strWb & "").Worksheets.Item(1).Range("L2:L" & Lr & "").NumberFormat = "d.mmm yy"
Workbooks("" & strWb & "").Close SaveChanges:=True
Let strWb = Dir
Loop While strWb <> ""
End Sub
Reply With Quote
Bookmarks