Change in macro

[Roman12]

Hi,
I have received the attached macro that does exactly what I asked for, but it would actually help if somebody could make a minor change in it.

The following macro copy pastes the data into different sheets. That means: in my sheet called Data, the macro copies the data in the whole row if the word xxx is written in column C and pastes it into the sheet with the same name.

Would it be possible to copy paste the data instead of the sheet into a new Excel file? This would mean, that the data of xxx would instead of in a sheet be placed into a new Excel file with the same name.

Thank you very much for your help.


Sub ExtractData()
Dim lr As Long
Dim i As Long

mysheet = Array("www", "xxx", "yyy")
lr = Sheets("Data").Range("C" & Rows.Count).End(xlUp).Row
Application.EnableEvents = False
Application.ScreenUpdating = False
For i = 0 To UBound(mysheet)
Sheets(mysheet(i)).UsedRange.ClearContents
With Sheets("Data").Range("A1:L" & lr)
.AutoFilter Field:=3, Criteria1:=mysheet(i)
.Copy Destination:=Sheets(mysheet(i)).Range("A1")
.AutoFilter
End With
Next i
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub

 

[Roman12]

Hi I will attach it to you in a minute. That would be very helpful

 

[Roman12]

Hi Peter I hope that you have received my file.

 

[Peter_SSs]

Hi Peter I hope that you have received my file.

Yes, and I'm making progress. I will report back here in the public thread.

 

[Peter_SSs]

OK, I think I have it.

1. Not the main problem, but this code should be in a standard module not the ThisWorkbook module. In the VB window Insert|Module and put the code there.

2. Again not the problem, but I have added a line near the top to ensure the new files get saved into the same folder as the original file.

3. The problem!!! In our discussions, you said the data was in a sheet called 'Data' It is actually in a sheet called 'Danske Bank' so the 'subscript out of range error was caused by Sheets("Data"). Since the file only has one sheet, I have replaced that with ActiveSheet.

4. I have also moved the screenupdating off up to the top which should further reduce screen flicker while the code runs.

So try this code:

<font face=Courier New><SPAN style="color:#00007F">Sub</SPAN> ExtractData()<br>    <SPAN style="color:#00007F">Dim</SPAN> lr <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">Long</SPAN><br>    <SPAN style="color:#00007F">Dim</SPAN> i <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">Long</SPAN><br>    <SPAN style="color:#00007F">Dim</SPAN> wb, ele<br>    <br>    Application.EnableEvents = <SPAN style="color:#00007F">False</SPAN><br>    Application.ScreenUpdating = <SPAN style="color:#00007F">False</SPAN><br>    ChDir ThisWorkbook.Path <SPAN style="color:#007F00">' <-- Ensures new files go in same folder as this file</SPAN><br>    mysheet = Array("All other", "APMM", "Arla", "Carlsberg", "ABB", _<br>                        "PBS", "SDC", "Danske Bank")<br>    <SPAN style="color:#00007F">For</SPAN> <SPAN style="color:#00007F">Each</SPAN> ele <SPAN style="color:#00007F">In</SPAN> mysheet<br>        <SPAN style="color:#00007F">Set</SPAN> wb = Workbooks.Add(xlWBATWorksheet)<br>        ActiveSheet.Name = ele<br>        wb.SaveAs ele & ".xls"<br>    <SPAN style="color:#00007F">Next</SPAN> ele<br>    ThisWorkbook.Activate<br>    lr = ActiveSheet.Range("C" & Rows.Count).End(xlUp).Row <SPAN style="color:#007F00">'<-- ActiveSheet not Sheets("Data")</SPAN><br>    <SPAN style="color:#00007F">For</SPAN> i = 0 <SPAN style="color:#00007F">To</SPAN> <SPAN style="color:#00007F">UBound</SPAN>(mysheet)<br>        <SPAN style="color:#00007F">With</SPAN> ActiveSheet.Range("A1:W" & lr) <SPAN style="color:#007F00">'<-- ActiveSheet not Sheets("Data")</SPAN><br>            .AutoFilter Field:=3, Criteria1:=mysheet(i)<br>            .Copy Destination:=Workbooks(mysheet(i) & ".xls").Sheets(mysheet(i)).Range("A1")<br>            .AutoFilter<br>        <SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">With</SPAN><br>        Workbooks(mysheet(i) & ".xls").Save<br>    <SPAN style="color:#00007F">Next</SPAN> i<br>    Application.EnableEvents = <SPAN style="color:#00007F">True</SPAN><br>    Application.ScreenUpdating = <SPAN style="color:#00007F">True</SPAN><br><SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">Sub</SPAN><br></FONT>

 

[Norie]

Perhaps this.

Sub DistributeRowsToNewWBS()
Dim wbNew As Workbook
Dim wsData As Worksheet
Dim wsCrit As Worksheet
Dim wsNew As Worksheet
Dim rngCrit As Range
Dim LastRow As Long
    
    Set wsData = Worksheets("Master (2)") ' name of worksheet with the data
    Set wsCrit = Worksheets.Add
    
    LastRow = wsData.Range("A" & Rows.Count).End(xlUp).Row
    
    ' column H has the criteria
    wsData.Range("H1:H" & LastRow).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=wsCrit.Range("A1"), Unique:=True
    
    Set rngCrit = wsCrit.Range("A2")
    While rngCrit.Value <> ""
        Set wsNew = Worksheets.Add
        ' change E to reflect columns to copy
        wsData.Range("A1:E" & LastRow).AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=rngCrit.Offset(-1).Resize(2), CopyToRange:=wsNew.Range("A1"), Unique:=True
        wsNew.Name = rngCrit
        wsNew.Copy
        Set wbNew = ActiveWorkbook
        ' saves new workbook in path of existing workbook
        wbNew.SaveAs ThisWorkbook.Path & "\" & rngCrit
        wbNew.Close SaveChanges:=True
        Application.DisplayAlerts = False
        wsNew.Delete
        rngCrit.EntireRow.Delete
        Set rngCrit = wsCrit.Range("A2")
    Wend
    
    wsCrit.Delete
    Application.DisplayAlerts = True
    
End Sub

 

[Roman12]

hi

I tried to implement it exactly the way you suggested and I also deleted the green writings. Why does it only copy paste the following? The rest seems to work.

<TABLE style="WIDTH: 240pt; BORDER-COLLAPSE: collapse" cellSpacing=0 cellPadding=0 width=320 border=0 x:str><COLGROUP><COL style="WIDTH: 48pt" span=5 width=64><TBODY><TR style="HEIGHT: 12.75pt" height=17><TD class=xl24 style="BORDER-RIGHT: windowtext 0.5pt solid; BORDER-TOP: windowtext 1pt solid; BORDER-LEFT: windowtext 1pt solid; WIDTH: 48pt; BORDER-BOTTOM: #e0dfe3; HEIGHT: 12.75pt; BACKGROUND-COLOR: #ffff99" width=64 height=17>Level</TD><TD class=xl25 style="BORDER-RIGHT: windowtext 0.5pt solid; BORDER-TOP: windowtext 1pt solid; BORDER-LEFT: windowtext; WIDTH: 48pt; BORDER-BOTTOM: #e0dfe3; BACKGROUND-COLOR: #ffff99" width=64>Caption</TD><TD class=xl25 style="BORDER-RIGHT: windowtext 0.5pt solid; BORDER-TOP: windowtext 1pt solid; BORDER-LEFT: windowtext; WIDTH: 48pt; BORDER-BOTTOM: #e0dfe3; BACKGROUND-COLOR: #ffff99" width=64>Position/Macro</TD><TD class=xl26 style="BORDER-RIGHT: windowtext 0.5pt solid; BORDER-TOP: windowtext 1pt solid; BORDER-LEFT: windowtext; WIDTH: 48pt; BORDER-BOTTOM: #e0dfe3; BACKGROUND-COLOR: #ffff99" width=64>Divider</TD><TD class=xl27 style="BORDER-RIGHT: windowtext 1pt solid; BORDER-TOP: windowtext 1pt solid; BORDER-LEFT: windowtext; WIDTH: 48pt; BORDER-BOTTOM: #e0dfe3; BACKGROUND-COLOR: #ffff99" width=64>FaceID</TD></TR></TBODY></TABLE>

 

[Roman12]

My bad. I figured it out. I just made the module into the wrong sheet. it works perfectly. Thank you very much.

 

[Peter_SSs]

My bad. I figured it out. I just made the module into the wrong sheet. it works perfectly. Thank you very much.

Good, I'm glad you figured that last bit out - I had no idea where those values came from!