Copy data from "All Levels" sheet to Master Sheet.

[Venkat10]

Hi
am new to Macro, Need your Help..!!

I have around 200+ excel files in folders and Sub folders, all files have "All Levels" sheet, what I want is to have an pop-up in my Master Sheet prompting for File name based on Partial file name I enter which matches with file names in directories and Sub-Directories it has to copy data from "All Levels" sheet of those files into my Master Sheet.

[werafa]

This can be done, but is moderately complex.
here is my code to give you a start, and something to help you search



Private Sub GetFile(sOfficeName As String)
' ----------------------------------------------------------------
' Procedure Name: GetFile
' Purpose: Update input file name and paths
' Parameter sOfficeName (String): pass office name for correct file/location id
' ----------------------------------------------------------------


Dim myObject As Object
Dim fileSelected As String
Dim myPath As String
Dim myFile As String
Dim strLen As Integer
Dim lRow As Integer
Dim mySheet As Worksheet

Call Runfast

Set myObject = Application.FileDialog(msoFileDialogOpen)
Set mySheet = ThisWorkbook.Worksheets("Admin")
lRow = mySheet.Range("B8:B15").Find(sOfficeName).Row

myPath = mySheet.Range("C" & lRow).Value
myPath = GetDefaultLocation(myPath)
myPath = GetLocalPath(myPath)

RedoGetFile:

' Get user file selection
With myObject
.Title = "Choose File"
.InitialFileName = myPath & "\"
.AllowMultiSelect = False
If .Show <> -1 Then
MsgBox ("No File Selected")
Exit Sub
End If
fileSelected = .SelectedItems(1)
End With

'check/convert onedrive path to local file path
fileSelected = GetLocalPath(fileSelected)

'Split into name and path
strLen = Len(fileSelected) - InStrRev(fileSelected, "\")
myFile = Right(fileSelected, strLen)
strLen = Len(fileSelected) - strLen - 1
myPath = Left(fileSelected, strLen)

'Update values
With Worksheets("Admin")
.Range("C" & lRow) = myPath 'The file path
.Range("D" & lRow) = myFile 'The file name
.Range("C" & lRow).Font.ColorIndex = 1
.Range("D" & lRow).Font.ColorIndex = 1
End With

If CheckFileName(myFile, sOfficeName) = False Then GoTo RedoGetFile

Call ResetExcel
End Sub


and


Public Function GetSourceWB(myString As String) As Workbook
'opens the source data WB & returns it as an object
Set GetSourceWB = Workbooks.Open( _
FileName:=myString, _
ReadOnly:=True, _
UpdateLinks:=False)

End Function

My code has various other function calls - ignore these, or use them as prompts for your own management procedures
good luck

Werafa

[Venkat10]

Hi Werafa,

Thanks for your response.

It copies file name as text but I want to copy data from "All Levels" sheet based on Specified file name to my Master sheet.

[werafa]

Getsourcewb function will open the workbook (using the text string), and return a workbook object.
you can then use this object to do something like


set myWB = getsourcewb(filestring)
set mySheet = myWB.worksheets("All Levels")

and then use the mysheet object to id the range you wish to copy

use


Application.DisplayAlerts = False myWB.Saved = True
myWB.Close
Application.DisplayAlerts = True



to close the WB when you have finished the copy operation. the only caveat is that this method closed the file without saving - so you should check whether the file is already open before doing this

[Venkat10]

Hi Werafa,

Can you consolidate code if you do so it will be of great help for me..!!
I tried but could not succeed.

[werafa]

the bit that generates the file name for the 'open the workbook' call is:



Private Function OpenSourceData(sOfficeName As String) As Workbook

Dim sourceWB As Workbook
Dim mySheet As Worksheet
Dim bFlag As Boolean
Dim sPath As String
Dim sFileName As String
Dim sFullPath As String
Dim lRow As Long




'get correct file name/path
Set mySheet = ThisWorkbook.Worksheets("Admin")
lRow = mySheet.Range("B8:B15").Find(sOfficeName).Row
sPath = mySheet.Range("C" & lRow).Value
sFileName = mySheet.Range("D" & lRow).Value
sFullPath = sPath & "\" & sFileName

'test whether workbook exists
If Dir(sFullPath) <> "" Then 'file exists at location
mySheet.Range("B" & lRow).Font.ColorIndex = 51
mySheet.Range("C" & lRow).Font.ColorIndex = 51


Else 'file does not exist at location
mySheet.Range("B" & lRow).Font.ColorIndex = 3
mySheet.Range("C" & lRow).Font.ColorIndex = 3
mySheet.Range("C" & lRow).Value = "File Not Found"
GoTo SomethingWentWrong
End If


'test whether workbook is locked
On Error GoTo SomethingWentWrong
bFlag = IsWorkBookOpen(sFullPath)
On Error GoTo 0
If bFlag = True Then GoTo FileIsLocked


'open the workbook and get the source data range
Set sourceWB = GetSourceWB(sFullPath) 'This is the open workbook call
Set OpenSourceData = sourceWB 'this gives the newly opened workbook to the function to return

Exit Function


FileIsLocked:
'-------------
MsgBox "The selected file is locked for editing." & vbCrLf & " Please close it and try again.", _
vbOKOnly Or vbInformation, "File is Locked for Editing"
'-------------
End


UserCancels:
End 'quit if files are locked for editing and user cancels

SomethingWentWrong:
MsgBox "Something Went Wrong: Input Data was not refreshed", vbOKOnly Or vbExclamation, "Abort"
ThisWorkbook.Worksheets("Admin").Activate
End

End Function


Function IsWorkBookOpen(FileName As String) As String' ----------------------------------------------------------------
' Procedure Name: IsWorkBookOpen
' Purpose: test whether file is open or closed
' Procedure Kind: Function
' Procedure Access: Public
' Parameter FileName (String): pass file name
' Return Type: String
' ----------------------------------------------------------------


Dim ff As Long
Dim ErrNo As Long


On Error Resume Next
ff = FreeFile()
Open FileName For Input Lock Read As #ff
Close ff
ErrNo = Err
On Error GoTo 0


Select Case ErrNo
Case 0: IsWorkBookOpen = "False"
Case 70: IsWorkBookOpen = "True"
Case Else: Error ErrNo
End Select
End Function

you will see that I've created the file name and path as cell values, and then read this to recreate the filename and path string to pass to the workbook-open function. The logic in this code gives you a basic level of error management/avoidance, and ends with a workbook object to pass on to the data management code.

there might still be calls to other subs or function - and you will get errors if there are (i'm getting a bit tired and am missing things now).
rem them out if there are and see if you can bypass them

Werafa

[werafa]

Hi Venkat10,

going back through the post, I do suggest that you treat the 'find file' and 'open file' as two separate operations. get each bit working, and then you can roll them up together into a single 'master' sub.

from my first post, rem out the 'call runfast' and 'call resetexcel'. These are procedures deal with sheet calculation and screen updating etc, and you can sort them out later if you wish.

'sOfficeName' is a string which the procedure looks up to find which row to find/store the file location info. this code has it passed from outside the procedure, but you could look it up or get it any way you wish.

'mySheet' is the worksheet on which the file location info is stored. change this to your location on the 'set mySheet' line

rem out 'myPath = GetDefaultLocation(myPath)', 'myPath = GetLocalPath(myPath)' and fileSelected = GetLocalPath(fileSelected)'. these are procedures that deal with issues created by OneDrive (tell me if you use this)


I've split the file name and path for readability, but this means that you have to reverse this when you open the file. Leave it or change it as you wish

I use font.colorindex to mark when the file name has been updated, and (in another procedure) change the color if the data is updated or the update procedure fails.

get this bit going and we can then go through the 'read the data' bit
Werafa

[Venkat10]

Hi Werafa,

Thanks a lot for your help..!!

Here is short code which does my job...But I want bit modification in this code..Please help me if you can..!!

Sub Copy_Data_Of_First_Sheets_Only()
Dim myPath As String, wb As String, a As Long
Application.ScreenUpdating = False
myPath = "C:\Users\Test Files" '<---- Change as Required
wb = Dir(myPath & "\*")
Do Until wb = ""
Workbooks.Open myPath & "" & wb
With Workbooks(wb).Sheets("All Levels")
a = IIf(Application.CountA(ThisWorkbook.Sheets("Master").Cells(1, 1).EntireRow) = 0, 0, 1) '<----- Here it is "Master" Where you copy, change as per need.
.UsedRange.Offset(a).Copy ThisWorkbook.Sheets("Master").Cells(Rows.Count, 1).End(xlUp).Offset(a) '<----- Here it is "Master" where you copy into. Change as required
End With
Workbooks(wb).Close False
wb = Dir
Loop
Application.ScreenUpdating = True
End Sub

This code copies data from all excel files in folder, What I want is POP Up asking for file name, When I enter partial name of file it has to copy data only from those files which matches with input.

[werafa]

k,

a little housekeeping first, can you enclose your code in code tags (the '#' icon), and make sure it has some basic indenting. it is heaps easier to read this way.

to get a user input text string, you can use an InputBox command. something like
sString = inputbox("User Message", "InputBox Title")

you can use instring to check whether one string is contained in another, eg
if not instr(string1, string2) = 0 then 'string match exists

Does this logic work with your thinking?

werafa

[Venkat10]

Yes it does..
But help me with consolidated code to get the job done...

Thanks for your response..!!

[werafa]

ok,

change sString to sPartName for readability, dimension the variable and add the input box before your do until loop

before 'workbooks.open, put the 'if not instr' and test whether your part name exists in the current file string, then
. proceed if it does
else
. Skip this file name
end if

does this make sense?
Werafa

[Venkat10]

Hi werafa,

Please let me know, where I have to edit.
I have edited and run but still irrespective of file name given its just copying data from all files contained in folder.

Here is code:
#Sub Copy_Data_Of_First_Sheets_Only() Dim myPath As String, wb As String, a As Long
Application.ScreenUpdating = False
myPath = "C:\Users\Test Files" '<---- Change as Required
wb = Dir(myPath & "\*")
ssPartName = InputBox("Input File Name", "File Name")
Do Until wb = ""
If Not InStr(string1, string2) = 0 Then 'string match exists
Else
End If
Workbooks.Open myPath & "" & wb
With Workbooks(wb).Sheets("All Levels")
a = IIf(Application.CountA(ThisWorkbook.Sheets("Master").Cells(1, 1).EntireRow) = 0, 0, 1) '<----- Here it is "Sheet1" where you copy into. Change as required
.UsedRange.Offset(a).Copy ThisWorkbook.Sheets("Master").Cells(Rows.Count, 1).End(xlUp).Offset(a) '<----- Here it is "Sheet1" where you copy into. Change as required
End With
Workbooks(wb).Close False
wb = Dir
Loop
Application.ScreenUpdating = True
End Sub

[werafa]

Hi Venkat10

The if then else statement controls what you di when you find a match, and when you do not find a match.
try



Do Until wb = ""
If Not InStr(string1, string2) = 0 Then 'string match exists
Workbooks.Open myPath & "" & wb
With Workbooks(wb).Sheets("All Levels")
a = IIf(Application.CountA(ThisWorkbook.Sheets("Master").Cells(1, 1).EntireRow) = 0, 0, 1) '<----- Here it is"Sheet1" where you copy into. Change as required
.UsedRange.Offset(a).Copy ThisWorkbook.Sheets("Master").Cells(Rows.Count, 1).End(xlUp).Offset(a) '<----- Here it is "Sheet1" where you copy into. Change as required
End With
Workbooks(wb).Close False
wb = Dir

Else
'skip this file
End If

Loop

Werafa

ps, the '#' is the icon on the menu bar of the edit screen - not the actual character. :)

[Venkat10]

Hi Werafa,

Its still copying data from all files..!!

For better clarity : If folders contain xls files having names as 900123_Apple, 65658_Samsung, 94643_Sony etc...
If I enter Samsung as input string it has to copy data from only those files which contain this name.

Thanks for your support..!!

[werafa]

String1 = wb, and string2 = the output from the inputbox. do you have this set correctly? the instr returns the position of the first instance of the search string, so instr("Venkat10", "10") would = 7. you are looking for any instance where instr does not = 0

add a watch on string1 and string2, what do you see when you step through line by line?

most important, do you have all the 'manage the open and copy' code inside the if then part of the statement? you only want to run this if the strings match, and skip this file if they do not

an easy way to enforce this is to move the 'open wb and copy data' section into a new sub-procedure and call this from the if statement

Werafa