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

Status
Not open for further replies.

BSECapac

New Member
Joined
Dec 29, 2022
Messages
5
Office Version
  1. 365
  2. 2021
  3. 2019
Platform
  1. Windows
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
 
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:

VBA 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
 
Upvote 0

Excel Facts

Excel Joke
Why can't spreadsheets drive cars? They crash too often!
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.
 
Upvote 0
Status
Not open for further replies.

Forum statistics

Threads
1,223,888
Messages
6,175,207
Members
452,618
Latest member
Tam84

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