Macro needed to copy specific (based on specific value in one of the columns) lines form one worksheet to another.

[BSECapac]

Hi All,

I am new in the VBA world, so maybe this question is somewhere here on this Forum, however I need your help to speed up one of my process.
On a daily basis I need to copy all lines with specific value (from one column) from the source sheet to another sheet. New sheet is having the same name as a value. Then I need to create a new file and copy a worksheet with a unique name into new file and save it under the name like: WEEK XX - (worksheet name), on an average it is about 20 different files.
What I am aiming for is to have the macro which will be doing below actions.

• Based on one of the columns from the source worksheet it will be creating new sheet with the unique name taken from the source sheet.
• Copying all lines from the source sheet with unique value (name from specific column) to already created new sheet with the same name.
• Creating new file and copying all of the data form specific (unique) sheet to the new file.
• Saving new file as WEEK XX (where xx will be a week number from 1 to 52) - sheet name (exp. New York, Dubai, Tokyo) - WEEK 51 - Dubai.xlsx in a specific folder (different folder name for different (unique) file name (Dubai, London, Tokyo, New York)

Hope it is not complicated and if it is then I would be great full for anything which will help me to reduce the time which I am spending o doing above things on a daily basis.

Thank you for any help on it.

Lately I have found below code on the internet, however it is only making sheets with unique name but without any content. (some fields are in polish :D )

Sub Work()
Dim ark As Worksheet, temp As Worksheet
Dim i As Integer

Set ark = Sheets("Result 1")
For i = 1 To ark.Range("d65536").End(xlUp).Row
If Not czyistnieje(ark.Cells(i, 3)) Then
Sheets.Add
Set temp = ActiveSheet
temp.name = ark.Cells(i, 3)
temp.Move After:=Sheets(Sheets.Count)
Call esql(ark.Cells(i, 3), temp.name)
End If
Next i

End Sub


Function esql(argument As String, arkusz As String)
Dim cn As Object, rs As Object
Dim nazwa As String, sqlstr As String
Dim ark As Worksheet

Set cn = CreateObject("ADODB.Connection")
Set rs = CreateObject("ADODB.Recordset")

nazwa = ActiveWorkbook.Path & Application.PathSeparator & ActiveWorkbook.name

cn.Open "Provider=Microsoft.Jet.OLEDB.4.0;" & _
"Data Source=" & nazwa & ";" & _
"Extended Properties=""Excel 8.0;HDR=No"""

sqlstr = "SELECT * FROM [Result 1$] WHERE F4 = '" & argument & "'"
Set rs = cn.Execute(sqlstr)
Set ark = ActiveWorkbook.Sheets(arkusz)

ark.Cells.ClearContents
ark.Range("a1").CopyFromRecordset rs

rs.Close
cn.Close

End Function

Function czyistnieje(nazwa As String) As Boolean
Dim ark As Worksheet
czyistnieje = False
For Each ark In ThisWorkbook.Worksheets
If ark.name = nazwa Then czyistnieje = True
Next ark
End Function

 

[shinigamilight]

XL2BB - Excel Range to BBCode

Excel 'mini-sheet' in messages - XL2BB Although experts prefer to read your description and question instead of working in your actual file to solve your problem, there are times that it is difficult to explain an issue without providing actual...

www.mrexcel.com

use this to provide sample data

 

[BSECapac]

Hi shinigamilight,

Unfortunately I can not install add-in on my computer (company restrictions), how we can do it in the other way around?
Below the snapshot of my file, no additional cell formatting, formulas, data validation, etc.

Greetings

 

[shinigamilight]

I'm not happy with this code, but you can try this, just carefully read the text in the green to set your custom path & sheet name and workbook name.

Sub well()
        Dim lr As Long
        Dim dic As Object
        Set dic = CreateObject("Scripting.Dictionary")
        Dim k As Integer
        Dim wk1 As Worksheet: Set wk1 = Workbooks("Book1.xlsm").Sheets("Sheet1") 'change workbook & sheet of source data
        Dim wb As Workbook: Set wb = Workbooks("Book1.xlsm") 'set the workbook name of the source data
        Dim store As String
        Dim v
        Dim fol  As String
        Dim cus As String
        fol = "C:\Users\Windows\Desktop\cool\"   'change the path where you want your files to be saved
       
        lr = wk1.Cells.Find("*", Cells(1, 1), xlFormulas, xlWhole, xlByRows, xlPrevious, False).Row

        For k = 2 To lr
                store = wk1.Range("C" & k)
                If dic.exists(store) = False Then
                    dic(store) = k
                    Sheets.Add.Name = store
                     wk1.Range("A" & k, wk1.Cells(k, wk1.Range("A1").End(xlToRight).Column)).Copy _
                     Sheets(store).Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
                     wk1.Range("A1", wk1.Cells(1, wk1.Range("A1").End(xlToRight).Column)).Copy _
                     Sheets(store).Cells(1, 1)
                Else: wk1.Range("A" & k, wk1.Cells(k, wk1.Range("A1").End(xlToRight).Column)).Copy _
                          Sheets(store).Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
                End If

          Next k
         
        For Each v In dic.keys
                cus = "WEEK " & WorksheetFunction.WeekNum(Date) & "-" & v
                MkDir (fol & v)
                store = fol & v
                Workbooks.Add.SaveAs store & "\" & cus
                wb.Sheets(v).Copy before:=Workbooks(cus & ".xlsx").Sheets(1)
                Workbooks(cus & ".xlsx").Close True
        Next v
       

End Sub

Excel vba Scripting Dictionary — Excel Dashboards VBA

The Excel scripting dictionary from the ground up. This blog post explains how the dictionary interacts with practical examples with an explanatory video series .

www.thesmallman.com

This article will tell you how to enable Microsoft Scripting Runtime.

 

[BSECapac]

Hi @shinigamilight,
All the best in 2023! Thank you for the help and code. Works super, it is really saving my time right now.
May I ask you why you are not happy with this code?
I have created a folder Test and empty folder WEEK 1, result is that folder WEEK 1 is empty and all other folders and files are in the folder TEST, the best and desirable end result is to have all files in the WEEK 1 folder (as it is by the week 51)
Could you help me with it?
Thank You.

 

[shinigamilight]

Sub well_2()
        Dim lr As Long
        Dim dic As Object
        Set dic = CreateObject("Scripting.Dictionary")
        Dim k As Integer
        Dim wk1 As Worksheet: Set wk1 = Workbooks("Book1.xlsm").Sheets("Sheet2") 'change workbook & sheet of source data
        Dim wb As Workbook: Set wb = Workbooks("Book1.xlsm") 'set the workbook name of the source data
        Dim store As String
        Dim v
        Dim fol  As String
        Dim cus, bucks As String
       
        fol = "C:\Users\Windows\Desktop\cool\"   'change the path where you want your files to be saved
       
        lr = wk1.Cells.Find("*", Cells(1, 1), xlFormulas, xlWhole, xlByRows, xlPrevious, False).Row

        For k = 2 To lr
                store = wk1.Range("C" & k)
                If dic.exists(store) = False Then
                    dic(store) = k
                    Sheets.Add.Name = store
                     wk1.Range("A" & k, wk1.Cells(k, wk1.Range("A1").End(xlToRight).Column)).Copy _
                     Sheets(store).Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
                     wk1.Range("A1", wk1.Cells(1, wk1.Range("A1").End(xlToRight).Column)).Copy _
                     Sheets(store).Cells(1, 1)
                Else: wk1.Range("A" & k, wk1.Cells(k, wk1.Range("A1").End(xlToRight).Column)).Copy _
                          Sheets(store).Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
                End If

          Next k
         
        For Each v In dic.keys
                cus = "WEEK " & WorksheetFunction.WeekNum(Date) & " - " & v
                bucks = "WEEK " & WorksheetFunction.WeekNum(Date)
                If Dir(fol & bucks, vbDirectory) = "" Then MkDir (fol & bucks)
                store = fol & bucks
                Workbooks.Add.SaveAs store & "\" & cus
                wb.Sheets(v).Copy before:=Workbooks(cus & ".xlsx").Sheets(1)
                Workbooks(cus & ".xlsx").Close True
        Next v
       

End Sub

 

[BSECapac]

Thank You, works perfect!!.

Where in the code I can change the week number from as it is now (based on the date 02/01/2023 - WEEK 1) to previous one WEEK 52?

 

[shinigamilight]

Thank You, works perfect!!.

Where in the code I can change the week number from as it is now (based on the date 02/01/2023 - WEEK 1) to previous one WEEK 52?

cus = "WEEK " & WorksheetFunction.WeekNum(Date) & " - " & v
bucks = "WEEK " & WorksheetFunction.WeekNum(Date)

The thing in bolded is responsible for the name of the folder and files.
bucks is the folder name and cus is the filename.

 

[BSECapac]

Hi,
How I need to change the code to receive desired result and it would be always a week back from now?
Thank You

 

[shinigamilight]

Sub well_3()
        Dim lr As Long
        Dim dic As Object
        Set dic = CreateObject("Scripting.Dictionary")
        Dim k As Integer
        Dim wk1 As Worksheet: Set wk1 = Workbooks("Book1.xlsm").Sheets("Sheet2") 'change workbook & sheet of source data
        Dim wb As Workbook: Set wb = Workbooks("Book1.xlsm") 'set the workbook name of the source data
        Dim store As String
        Dim v
        Dim fol  As String
        Dim cus, bucks As String
        Dim week As Long
       
        fol = "C:\Users\Windows\Desktop\cool\"   'change the path where you want your files to be saved
       
        lr = wk1.Cells.Find("*", Cells(1, 1), xlFormulas, xlWhole, xlByRows, xlPrevious, False).Row

        For k = 2 To lr
                store = wk1.Range("C" & k)
                If dic.exists(store) = False Then
                    dic(store) = k
                    Sheets.Add.Name = store
                     wk1.Range("A" & k, wk1.Cells(k, wk1.Range("A1").End(xlToRight).Column)).Copy _
                     Sheets(store).Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
                     wk1.Range("A1", wk1.Cells(1, wk1.Range("A1").End(xlToRight).Column)).Copy _
                     Sheets(store).Cells(1, 1)
                Else: wk1.Range("A" & k, wk1.Cells(k, wk1.Range("A1").End(xlToRight).Column)).Copy _
                          Sheets(store).Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
                End If

          Next k
       
        week = WorksheetFunction.WeekNum(Date) - 1
        If week = 0 Then week = 52
        bucks = "WEEK " & week
        If Dir(fol & bucks, vbDirectory) = "" Then MkDir (fol & bucks)
       
        For Each v In dic.keys
                cus = "WEEK " & week & " - " & v
                store = fol & bucks
                Workbooks.Add.SaveAs store & "\" & cus
                wb.Sheets(v).Copy before:=Workbooks(cus & ".xlsx").Sheets(1)
                Workbooks(cus & ".xlsx").Close True
        Next v
       

End Sub