change code to comine data in the same sheet instead of add sheets

K

KalilMe

Active Member
Joined
Mar 5, 2021
Messages
382
Office Version
  1. 2016
Platform
  1. Windows
Hello

I want modifying code to brings data in sheet name DATA in main file when select folder to pull data from sheet name DATA in all of files are existed in selected folder instead of add sheet name like DATA(1) ,DATA(2) ....so on after first sheet name DATA and combining values in columns C,D for duplicates items based on matching ID for column B and autonumbering in column A.




VBA Code: 
Sub test()
Dim FSO As Object, FolDir As Object, FileNm As Object
Dim TargetFolder As FileDialog, Sht As Worksheet, Cnter As Integer
Set TargetFolder = Application.FileDialog(msoFileDialogFolderPicker)
With TargetFolder
.AllowMultiSelect = False
.Title = "Select Folder:"
.Show
End With
If TargetFolder.SelectedItems.Count = 0 Then
MsgBox "PICK A Folder!"
Exit Sub
End If
On Error GoTo Erfix
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set FSO = CreateObject("scripting.filesystemobject")
Set FolDir = FSO.GetFolder(Application.FileDialog(msoFileDialogFolderPicker).SelectedItems(1))
For Each FileNm In FolDir.Files
If FileNm.Name Like "*" & ".xls" & "*" Then
Workbooks.Open Filename:=FileNm
For Each Sht In Workbooks(FileNm.Name).Worksheets
If LCase(Sht.Name) = LCase("Data") Then
Cnter = Cnter + 1
Workbooks(FileNm.Name).Sheets("Data").copy _
After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
Sht.Name = "Data" & Cnter
Workbooks(FileNm.Name).Close savechanges:=False
Exit For
End If
Next Sht
End If
Next FileNm
Erfix:
Application.DisplayAlerts = True
Application.ScreenUpdating = True
Set FolDir = Nothing
Set FSO = Nothing
End Sub
thanks
 

Excel Facts

What did Pito Salas invent?
Pito Salas, working for Lotus, popularized what would become to be pivot tables. It was released as Lotus Improv in 1989.
Sort by date Sort by votes
Hi KalilMe,

maybe

VBA Code: 
Sub test_mod()
' https://www.mrexcel.com/board/threads/change-code-to-comine-data-in-the-same-sheet-instead-of-add-sheets.1224447/
Dim FSO As Object
Dim FolDir As Object
Dim FileNm As Object
Dim TargetFolder As FileDialog
Dim Sht As Worksheet
Dim wksColl As Worksheet
Dim blnDel As Boolean

Set wksColl = Worksheets.Add(after:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count))
blnDel = True

Set TargetFolder = Application.FileDialog(msoFileDialogFolderPicker)
With TargetFolder
  .AllowMultiSelect = False
  .Title = "Select Folder:"
  .Show
End With
If TargetFolder.SelectedItems.Count = 0 Then
  MsgBox "PICK A Folder!"
  Exit Sub
End If

On Error GoTo Erfix
Application.ScreenUpdating = False
Application.DisplayAlerts = False

Set FSO = CreateObject("scripting.filesystemobject")
Set FolDir = FSO.GetFolder(Application.FileDialog(msoFileDialogFolderPicker).SelectedItems(1))
For Each FileNm In FolDir.Files
  If FileNm.Name Like "*" & ".xls" & "*" Then
    Workbooks.Open Filename:=FileNm
    For Each Sht In Workbooks(FileNm.Name).Worksheets
      If LCase(Sht.Name) = LCase("Data") Then
        Sht.UsedRange.Copy wksColl.Range("A" & wksColl.Rows.Count).End(xlUp).Offset(1, 0)
        blnDel = False
        Workbooks(FileNm.Name).Close savechanges:=False
        Exit For
      End If
    Next Sht
  End If
Next FileNm

Erfix:
If blnDel Then wksColl.Delete
Application.DisplayAlerts = True
Application.ScreenUpdating = True
Set wksColl = Nothing
Set FolDir = Nothing
Set FSO = Nothing
Set TargetFolder = Nothing
End Sub

Ciao,
Holger
 
Upvote 0
very good try buddy !
I have somthings to make clearing:
1- the main file where run the macro contains sheet DATA , so just brings data from multiple files for sheet DATA without add any sheet, in reality your version will add sheet and brings data after existed sheet name DATA .
2- should ignore the headers , your version will also copy headers.
3- this part seems difficult . as I said there is duplicats items so I want summing the values for column C,D for duplicates items based on matching column B
I hope you can help
 
Upvote 0
Hi KalilMe,

getting the data in a form that you like could be done like this:

VBA Code: 
Sub test_mod_Vers2()
' https://www.mrexcel.com/board/threads/change-code-to-comine-data-in-the-same-sheet-instead-of-add-sheets.1224447/
Dim FSO As Object
Dim FolDir As Object
Dim FileNm As Object
Dim TargetFolder As FileDialog
Dim Sht As Worksheet
Dim wksColl As Worksheet

On Error GoTo Erfix
Set wksColl = ThisWorkbook.Worksheets("Data")

Set TargetFolder = Application.FileDialog(msoFileDialogFolderPicker)
With TargetFolder
  .AllowMultiSelect = False
  .Title = "Select Folder:"
  .Show
End With
If TargetFolder.SelectedItems.Count = 0 Then
  MsgBox "PICK A Folder!"
  Exit Sub
End If

Application.ScreenUpdating = False
Application.DisplayAlerts = False

Set FSO = CreateObject("scripting.filesystemobject")
Set FolDir = FSO.GetFolder(Application.FileDialog(msoFileDialogFolderPicker).SelectedItems(1))
For Each FileNm In FolDir.Files
  If FileNm.Name Like "*" & ".xls" & "*" Then
    Workbooks.Open Filename:=FileNm
    For Each Sht In Workbooks(FileNm.Name).Worksheets
      If LCase(Sht.Name) = LCase("Data") Then
        Sht.UsedRange.Offset(1).Copy wksColl.Range("B" & wksColl.Rows.Count).End(xlUp).Offset(1, 0)
        Workbooks(FileNm.Name).Close savechanges:=False
        Exit For
      End If
    Next Sht
  End If
Next FileNm

Erfix:
Application.DisplayAlerts = True
Application.ScreenUpdating = True
Set wksColl = Nothing
Set FolDir = Nothing
Set FSO = Nothing
Set TargetFolder = Nothing
End Sub

But I have trouble understanding what you want to be summed: the values in Column C as well as D indepently for the whole area just copied? Or summed up by anything like an ID in Column B (but in which column)? And the numbering: each area on it's own or going through?

Maybe you can attach the information by using XL2BB (or via picture).

Holger
 
Upvote 0
But I have trouble understanding what you want to be summed: the values in Column C as well as D indepently for the whole area just copied? Or summed up by anything like an ID in Column B (but in which column)? And the numbering: each area on it's own or going through?

Maybe you can attach the information by using XL2BB (or via picture).
Click to expand...
here is data for the some files in folder

first file
MAS.xlsm
ABCD
1ITEMCODEINPUTOUTPUT
21F00D-BANANA-11010
32F00D-BANANA-220
43F00D-BANANA-330
54F00D-BANANA-4402
65F00D-BANANA-5502
76F00D-BANANA-6602
87F00D-BANANA-770
98F00D-BANANA-88012
109F00D-BANANA-99013
1110F00D-BANANA-1010045
1211F00D-BANANA-1111066
1312F00D-BANANA-1212054
1413F00D-BANANA-131302
1514F00D-BANANA-141403
1615F00D-BANANA-15150
1716F00D-BANANA-16160
1817F00D-BANANA-1717012
1918F00D-BANANA-1818012
DATA


second file
LAST.xlsm
ABCD
1ITEMCODEINPUTOUTPUT
21F00D-BANANA-712
32F00D-BANANA-811
43F00D-BANANA-990
54F00D-BANANA-220
65F00D-BANANA-3121
76F00D-BANANA-412
87F00D-BANANA-5122
98F00D-BANANA-6452
109F00D-BANANA-13310
1110F00D-BANANA-106645
1211F00D-BANANA-117766
1312F00D-BANANA-128854
1413F00D-BANANA-131302
1514F00D-BANANA-141403
1615F00D-BANANA-15150
1716F00D-BANANA-16160
1817F00D-BANANA-1717012
1918F00D-BANANA-1818012
DATA

result in file master after summing in column C,D for duplicates items based on column B with re-autonumbering in column A
MASTER.xlsm
ABCD
1ITEMCODEINPUTOUTPUT
21F00D-BANANA-14320
32F00D-BANANA-2400
43F00D-BANANA-3421
54F00D-BANANA-4414
65F00D-BANANA-5624
76F00D-BANANA-61054
87F00D-BANANA-7820
98F00D-BANANA-89112
109F00D-BANANA-918013
1110F00D-BANANA-1016690
1211F00D-BANANA-11187132
1312F00D-BANANA-12208108
1413F00D-BANANA-132604
1514F00D-BANANA-142806
1615F00D-BANANA-153000
1716F00D-BANANA-163200
1817F00D-BANANA-1734024
1918F00D-BANANA-1836024
DATA

I hope this help
 
Upvote 0
Hi KalilMe,

using standard VBA commands like

VBA Code: 
Sub test_mod_Vers3()
' https://www.mrexcel.com/board/threads/change-code-to-comine-data-in-the-same-sheet-instead-of-add-sheets.1224447/
Dim FSO As Object
Dim FolDir As Object
Dim FileNm As Object
Dim TargetFolder As FileDialog
Dim Sht As Worksheet
Dim wksColl As Worksheet
Dim lngRow As Long

On Error GoTo Erfix
Set wksColl = ThisWorkbook.Worksheets("Data")

Set TargetFolder = Application.FileDialog(msoFileDialogFolderPicker)
With TargetFolder
  .AllowMultiSelect = False
  .Title = "Select Folder:"
  .Show
End With
If TargetFolder.SelectedItems.Count = 0 Then
  MsgBox "PICK A Folder!"
  Exit Sub
End If

Application.ScreenUpdating = False
Application.DisplayAlerts = False

Set FSO = CreateObject("scripting.filesystemobject")
Set FolDir = FSO.GetFolder(Application.FileDialog(msoFileDialogFolderPicker).SelectedItems(1))
For Each FileNm In FolDir.Files
  If FileNm.Name Like "*" & ".xls" & "*" Then
    Workbooks.Open Filename:=FileNm
    For Each Sht In Workbooks(FileNm.Name).Worksheets
      If LCase(Sht.Name) = LCase("Data") Then
        Sht.UsedRange.Offset(1).Copy wksColl.Range("A" & wksColl.Rows.Count).End(xlUp).Offset(1, 0)
        Workbooks(FileNm.Name).Close savechanges:=False
        Exit For
      End If
    Next Sht
  End If
Next FileNm

wksColl.Range("A1").CurrentRegion.Sort Key1:=Range("B1"), _
      Order1:=xlAscending, _
      Header:=xlYes, _
      OrderCustom:=1, _
      MatchCase:=False, _
      Orientation:=xlTopToBottom, _
      DataOption1:=xlSortNormal

For lngRow = wksColl.Cells(wksColl.Rows.Count, "B").End(xlUp).Row To 3 Step -1
  With wksColl.Cells(lngRow, "B")
    If .Value = .Offset(-1, 0).Value Then
      .Offset(-1, 1).Value = .Offset(-1, 1).Value + .Offset(, 1).Value
      .Offset(-1, 2).Value = .Offset(-1, 2).Value + .Offset(, 2).Value
      .EntireRow.Delete
    End If
  End With
Next lngRow

wksColl.Range("A1").CurrentRegion.Sort Key1:=Range("A1"), _
      Order1:=xlAscending, _
      Header:=xlYes, _
      OrderCustom:=1, _
      MatchCase:=False, _
      Orientation:=xlTopToBottom, _
      DataOption1:=xlSortNormal

wksColl.Range("A1:D1").EntireColumn.AutoFit

Erfix:
Application.DisplayAlerts = True
Application.ScreenUpdating = True
Set wksColl = Nothing
Set FolDir = Nothing
Set FSO = Nothing
Set TargetFolder = Nothing
End Sub

Ciao,
Holger
 
Upvote 0
awesome !
just two things:
1- I want clearing data from row2 in file MASTER before bring data because I note to repeat summing over values are already existed repeatedly .
2- I want sort data from small to big after merging
thanks for your time .
 
Upvote 0
Hi KalilMe,

two small adjustments to the code:

VBA Code: 
Sub test_mod_Vers4()
' https://www.mrexcel.com/board/threads/change-code-to-comine-data-in-the-same-sheet-instead-of-add-sheets.1224447/
Dim FSO As Object
Dim FolDir As Object
Dim FileNm As Object
Dim TargetFolder As FileDialog
Dim Sht As Worksheet
Dim wksColl As Worksheet
Dim lngRow As Long

On Error GoTo Erfix
Set wksColl = ThisWorkbook.Worksheets("Data")
'/// clear the used range but keep headings
wksColl.UsedRange.Offset(1, 0).ClearContents

Set TargetFolder = Application.FileDialog(msoFileDialogFolderPicker)
With TargetFolder
  .AllowMultiSelect = False
  .Title = "Select Folder:"
  .Show
End With
If TargetFolder.SelectedItems.Count = 0 Then
  MsgBox "PICK A Folder!"
  Exit Sub
End If

Application.ScreenUpdating = False
Application.DisplayAlerts = False

Set FSO = CreateObject("scripting.filesystemobject")
Set FolDir = FSO.GetFolder(Application.FileDialog(msoFileDialogFolderPicker).SelectedItems(1))
For Each FileNm In FolDir.Files
  If FileNm.Name Like "*" & ".xls" & "*" Then
    Workbooks.Open Filename:=FileNm
    For Each Sht In Workbooks(FileNm.Name).Worksheets
      If LCase(Sht.Name) = LCase("Data") Then
        Sht.UsedRange.Offset(1).Copy wksColl.Range("A" & wksColl.Rows.Count).End(xlUp).Offset(1, 0)
        Workbooks(FileNm.Name).Close savechanges:=False
        Exit For
      End If
    Next Sht
  End If
Next FileNm

wksColl.Range("A1").CurrentRegion.Sort Key1:=Range("B1"), _
      Order1:=xlAscending, _
      Header:=xlYes, _
      OrderCustom:=1, _
      MatchCase:=False, _
      Orientation:=xlTopToBottom, _
      DataOption1:=xlSortNormal

For lngRow = wksColl.Cells(wksColl.Rows.Count, "B").End(xlUp).Row To 3 Step -1
  With wksColl.Cells(lngRow, "B")
    If .Value = .Offset(-1, 0).Value Then
      .Offset(-1, 1).Value = .Offset(-1, 1).Value + .Offset(, 1).Value
      .Offset(-1, 2).Value = .Offset(-1, 2).Value + .Offset(, 2).Value
      .EntireRow.Delete
    End If
  End With
Next lngRow

'/// change Column to suit, here it is for sorting Input low to high
wksColl.Range("A1").CurrentRegion.Sort Key1:=Range("C1"), _
      Order1:=xlAscending, _
      Header:=xlYes, _
      OrderCustom:=1, _
      MatchCase:=False, _
      Orientation:=xlTopToBottom, _
      DataOption1:=xlSortNormal

wksColl.Range("a1:D1").EntireColumn.AutoFit
  
Erfix:
Application.DisplayAlerts = True
Application.ScreenUpdating = True
Set wksColl = Nothing
Set FolDir = Nothing
Set FSO = Nothing
Set TargetFolder = Nothing
End Sub

Ciao,
Holger
 
Upvote 0
thanks gain
just I need fixing the sort, doesn't seem arranging correctly
this is what I got
MASTER.xlsm
ABCD
1ITEMCODEINPUTOUTPUT
24F00D-BANANA-2400
36F00D-BANANA-4414
45F00D-BANANA-3421
59F00D-BANANA-14320
67F00D-BANANA-5624
71F00D-BANANA-7820
82F00D-BANANA-89112
98F00D-BANANA-61054
1010F00D-BANANA-1016690
113F00D-BANANA-918013
1211F00D-BANANA-11187132
1312F00D-BANANA-12208108
1413F00D-BANANA-132604
1514F00D-BANANA-142806
1615F00D-BANANA-153000
1716F00D-BANANA-163200
1817F00D-BANANA-1734024
1918F00D-BANANA-1836024
DATA
 
Upvote 0
Hi KalilMe,

just I need fixing the sort, doesn't seem arranging correctly
Click to expand...

Please be more precise when asking for

2- I want sort data from small to big after merging
Click to expand...

What column/item? And don't post what you have but what the outcome should look like: the original request how data should look like was posted by you in #5, you are asking for something different than that by now.

Holger
 
Upvote 0
You must log in or register to reply here.

Similar threads

R
  • Solved
Go through subfolders, select matching files and copy a worksheet from each into a master file
2
Replies
17
Views
897
BatTodor
B
mmn1000
  • Question Question
List folders and files
Replies
1
Views
777
Fuji
F
S
  • Question Question
Adding a new field to the results of my "list the folders inside a specific folder" code
Replies
2
Views
295
John_w
J
C
  • Question Question
Need to add to my search worksheet
Replies
1
Views
104
craigwojo
C
I
  • Question Question
Error "Unable to set the Name property of the PivotTable class"
Replies
1
Views
249
RoryA
RoryA

Forum statistics

Threads
1,223,888
Messages
6,175,203
Members
452,617
Latest member
Narendra Babu D

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top