PDA

View Full Version : Help in VBA to transfer data into multiple files in a folder



Kartyk
09-18-2016, 01:43 AM
The below data updates other sheets within a file using the first columns as key. I would need to replicate the same logic whereby updating different files in a folder. Files can have a sheet name pre-
defined.

Help would be greatly appreciated.

Sub UpdateData()


Dim xRow As Long, yCol As Long, k As Long, intPos As Long
Dim ws As Worksheet, wsMaster As Worksheet
Dim dataCompare As String, destCompare As String
Dim destRange As Range, copyRange As Range


On Error Resume Next
Application.ScreenUpdating = False
Set wsMaster = Worksheets("Mastersheet")
wsMaster.Select
xRow = Cells(Rows.Count, "A").End(xlUp).Row
yCol = Cells(1, Columns.Count).End(xlToLeft).Column
For k = 2 To xRow
wsMaster.Select
dataCompare = Trim(CStr(Range("A" & k)))
For Each ws In Worksheets
intPos = 0
If ws.Name <> "master" Then
ws.Select
Set destRange = Range("A2:A" & Cells(Rows.Count, "A").End(xlUp).Row)
intPos = Application.WorksheetFunction.Match(dataCompare, destRange, 0)
If intPos > 0 Then
Application.CutCopyMode = False
wsMaster.Select
Set copyRange = Range(Cells(k, 1), Cells(k, yCol))
copyRange.Copy
ws.Select
Range("A" & intPos + 1).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
End If
End If
Next
Next
Application.ScreenUpdating = True
End Sub

Cheers

mana
09-18-2016, 02:42 AM
Option Explicit

Sub test()
Dim myFld As String
Dim myName As String
Dim myBook As Workbook

With Application.FileDialog(msoFileDialogFolderPicker)
If .Show = 0 Then Exit Sub
myFld = .SelectedItems(1) & "\"
End With

myName = Dir(myFld & "*.xls")

Do While myName <> ""
Set myBook = Workbooks.Open(Filename:=myFld & myName)
Call UpdateData(myBook)
myBook.Close True

myName = Dir()
Loop

End Sub


Private Sub UpdateData(wb As workbook)
'
end sub

Kartyk
09-18-2016, 04:42 AM
Hi Mana, thank you. Could you please help me integrate the code and also, I do not want folder picker. I woul define a path and it stays constant.

Cheers

mana
09-18-2016, 05:07 AM
Option Explicit

Sub test()
Dim myFld As String
Dim myName As String
Dim myBook As Workbook

myFld = CreateObject("WScript.Shell").SpecialFolders("DeskTop") & "\test\"

myName = Dir(myFld & "*.xls")

Do While myName <> ""
Set myBook = Workbooks.Open(Filename:=myFld & myName)
Call UpdateData(myBook)
myBook.Close True

myName = Dir()
Loop

End Sub


Private Sub UpdateData(wb As Workbook)
Dim xRow As Long, yCol As Long, k As Long, intPos As Variant
Dim ws As Worksheet, wsMaster As Worksheet
Dim dataCompare As String, destCompare As String
Dim destRange As Range, copyRange As Range


Application.ScreenUpdating = False

Set wsMaster = wb.Worksheets("Mastersheet")

With wsMaster
xRow = .Cells(.Rows.Count, "A").End(xlUp).Row
yCol = .Cells(1, .Columns.Count).End(xlToLeft).Column

For k = 2 To xRow
dataCompare = Trim(CStr(.Range("A" & k)))
For Each ws In wb.Worksheets
If ws.Name <> "master" Then
Set destRange = ws.Range("A2", ws.Cells(ws.Rows.Count, "A").End(xlUp))
intPos = Application.Match(dataCompare, destRange, 0)
If IsNumeric(intPos) Then
ws.Range("A" & intPos + 1).Resize(, yCol).Value = _
.Range("A" & k).Resize(, yCol).Value
End If
End If
Next
Next
End With

Application.ScreenUpdating = True

End Sub

mana
09-18-2016, 05:59 AM
worksheet name should be corrected


> Set wsMaster = wb.Worksheets("Mastersheet")
> If ws.Name <> "master" Then

Kartyk
09-19-2016, 12:46 AM
Yes, thanks a lot.