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

 

[MoonLove]

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]

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.