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



## BSECapac (Dec 29, 2022)

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 (Dec 29, 2022)

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 (Dec 30, 2022)

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 (Dec 30, 2022)

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 (Jan 2, 2023)

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 (Jan 2, 2023)

```
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 (Jan 2, 2023)

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 (Jan 2, 2023)

BSECapac said:


> 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 (Jan 3, 2023)

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 (Jan 3, 2023)

```
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
```


----------



## BSECapac (Dec 29, 2022)

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


----------



## MoonLove (Yesterday at 1:02 PM)

Hi Team,

I have the below problem statement. Please help as I have a very urgent project to deliver.

- I have *4 source workbooks* called *GK, SK,RJ and TB.*
- Each of the above source worksheets have three worksheets called *channels, products and sales.*
- Each sheet in all the four workbooks(GK,SK,RJ and TB) have the same table format as below:


Date


Lead Code


Lead Name

YTD

Sales Code

08-01-2023


102


Serengeti

2023


201


08-01-2023

103

Manyara

2023

202

08-01-2023

104

Mikumi

2023

203

- My *destination workbook* is called *CONSOLIDATED MI REPORT*, it has 3 sheet with the same name as of those 4 workbooks*(channels, products and sales).*
- I ran the macro on the *CONSOLIDATED MI REPORT* standard module with the expectation that it has to pull/copy data from each sheet(channels, products, and sales) on each individual workbooks*(GK,SK,RJ and TB) *and paste it to CONSOLIDATED MI REPORT.
- My challenge is when the macro runs, it copies everything even the data that was previously copied from each sheet on individual workbooks *GK, SK, RJ, and TB.*
- Please see the below code where am I supposed to amend on the below code:


```
Sub Copy_From_All_Workbooks()
Dim wb As String
Dim sh As Worksheet
Dim lngStartCopy As Long, Lrow As Long

'RunMacro = Now + TimeValue("00:30:00")
'Application.OnTime RunMacro, "Copy_From_All_Workbooks"
Application.ScreenUpdating = False
wb = Dir(ThisWorkbook.Path & "\*")
Do Until wb = ""
     If wb <> ThisWorkbook.Name Then
          Workbooks.Open ThisWorkbook.Path & "\" & wb
          For Each sh In Workbooks(wb).Worksheets
               lngStartCopy = sh.Cells(Rows.Count, "F").End(xlUp).Row + 1 'where to start copied range
               Lrow = sh.Cells(Rows.Count, "A").End(xlUp).Row 'where last row is with data in column A
              
               'if sheet is blank or flag/data is wrong, start row can be greater than end row
               If Not lngStartCopy > Lrow Then '
                    sh.Range("A" & lngStartCopy & ":A" & Lrow).EntireRow.Copy
                    ThisWorkbook.Sheets(sh.Name).Cells(Rows.Count, 1).End(xlUp).Offset(1).PasteSpecial xlPasteValues
                    Application.CutCopyMode = False
                    sh.Range("F" & lngStartCopy & ":F" & Lrow) = Date
               End If
          Next sh
          Workbooks(wb).Close False
     End If
wb = Dir
Loop

Application.ScreenUpdating = True

End Sub
```


----------



## Fluff (Yesterday at 1:05 PM)

Duplicate to: CONSOLIDATED MI REPORT

In future, please do not post the same question multiple times. Per Forum Rules (#12), posts of a duplicate nature will be locked or deleted.

In relation to your question here, I have closed this thread so please continue in the linked thread.


----------

