Copy data from dynamically named source file into master file - excel

I have a Master workbook (Consolidate Tracker) where we add data from Source file.
Consolidated Tracker and Source file have three tabs (Open Positions, Closed, Cancelled).
Every week I put data from Source file (from each tab) into the Consolidated file (to each tab).
For example: Open Positions data from Source file goes to Open Positions in Consolidated Tracker and so on.
I am facing the following issues:
I have to give full name of the files.
For example. Workbooks("Source*") is not working.
Is there a way to give only partial names?
My file name will have a date in the end. Hence I want to give *.
ActiveWorkbook.Sheets(I) or ActiveWorkbook.Sheets("Name") always goes for the Open Worksheet/Tab.
Pasting the output gives the following error.
Method PasteSpecial of Object Range Failed
Selection.EntireRow.Delete sometimes gives error or sometimes
doesn’t delete and again goes into For loop.
Also, it seems the loop is not taking the next tab.
Sub GetSheets()
Set objExcel = CreateObject("Excel.Application")
Set objWorkbook = objExcel.Workbooks.Open("D:\2018\ VBA\Consolidated Tracker.xlsm")
Workbooks("Source_Tracker.xlsx").Activate
For I = 1 To 3
Set Sheet = ActiveWorkbook.Sheets(I)
Columns("A:A").Select
Selection.Insert Shift:=xlToRight
Range("A1").Select
Dim LastRow As Long
LastRow = Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
With Range("A1:A" & LastRow)
.Value = Date
.NumberFormat = "mm/dd/yy"
End With
Range("A1").Select
ActiveCell.Offset(1, 0).Select
Selection.CurrentRegion.Copy
Workbooks("Consolidated Tracker").Activate
Set Sheet = Workbooks("Consolidated Tracker.xlsm").Sheets(I)
Range("A100000").Select
Selection.End(xlUp).Select
ActiveCell.Offset(1, 0).Select
ActiveCell.PasteSpecial
ActiveCell.Offset(0, 0).Select
Selection.EntireRow.Delete
Next I
End Sub

Consider this rewrite.
Option Explicit
Sub GetSheets()
Dim i As Long, lr As Long
Dim wb1 As Workbook, wb1 As Workbook
Application.Workbooks.Open Filename:="D:\2018\ VBA\Consolidated Tracker.xlsm", _
ReadOnly:=True, AddToMru:=False
setWbs wb1, wb2
With wb1
For i = 1 To 3
With .Worksheets(i)
.Columns("A:A").Insert Shift:=xlToRight
lr = Cells.Find(what:="*", after:=.Cells(1), _
SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
With .Range(.Cells(1, "A"), .Cells(lr, "A"))
.Value = Date
.NumberFormat = "mm/dd/yy"
End With
.Cells(1, "A").CurrentRegion.offset(1, 0).Copy _
Destination:=wb2.Worksheets(i).Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)
End With
Next i
End With
End Sub
Sub setWbs(ByRef wkbk1 As Workbook, ByRef wkbk2 As Workbook)
Dim wb As Long
For wb = 1 To application.Workbooks.Count
Select Case left(LCase(Workbooks(wb).name), 7)
Case "source_"
Set wkbk1 = Workbooks(wb)
Case "consoli"
Set wkbk2 = Workbooks(wb)
End Select
Next wb
End Sub

Related

Expanding macro for sorting and copy/pasting data to other worksheets

I export a schedule from MS Teams to Excel for data manipulation.
I made a macro that changes the dates field to a date format for the EU and sorts by it by date.
Then it goes to the next worksheet and checks the names of employees and creates a worksheet for each of the names.
Then it jumps back to the first worksheet, sorts by "name" criteria and copies the data for every single one to its own respective worksheet.
This is what I got so far that is OK:
Sub Temp1()
'Convert Cell Format from Text to Date and change MDY to DMY Format
Sheets("Shifts").Select
Range("D2:D1000").Select
Selection.TextToColumns Destination:=Range("D2"), DataType:=xlFixedWidth, _
FieldInfo:=Array(0, 3), TrailingMinusNumbers:=True
Range("F2:F1000").Select
Selection.TextToColumns Destination:=Range("F2"), DataType:=xlFixedWidth, _
FieldInfo:=Array(0, 3), TrailingMinusNumbers:=True
'Add the Sheets for each member of the "Members" Sheet
Sheets("Members").Select
Dim xRg As Excel.Range
Dim wSh As Excel.Worksheet
Dim wBk As Excel.Workbook
Set wSh = ActiveSheet
Set wBk = ActiveWorkbook
Application.ScreenUpdating = False
For Each xRg In wSh.Range("A2:A22")
With wBk
.Sheets.Add After:=.Sheets(.Sheets.Count)
ActiveCell.FormulaR1C1 = "Evidencija radnog vremena"
Selection.Font.Size = 20
Selection.Font.Bold = True
ActiveCell.Offset(1, 0).Range("A1").Select
ActiveCell.FormulaR1C1 = "Godina i mjesec"
Selection.Font.Size = 14
Selection.Font.Bold = True
ActiveCell.Offset(1, 0).Range("A1").Select
ActiveCell.FormulaR1C1 = "Radnik"
Selection.Font.Bold = True
ActiveCell.Offset(2, 0).Range("A1").Select
On Error Resume Next
ActiveSheet.Name = xRg.Value
Range("B2").Value = ActiveSheet.Name
If Err.Number = 1004 Then
Debug.Print xRg.Value & " already used as a sheet name"
End If
On Error GoTo 0
End With
Next xRg
Application.ScreenUpdating = True
'Sort by Date
Sheets("Shifts").Select
Range("A1").Sort Key1:=Range("D1"), Order1:=xlAscending, Header:=xlYes
After this I need some kind of loop or switch case or Foreach - i don't know what exactly.
I have it hardcoded for now, but it will become bulky, slow and problematic to maintain.
What I need to do:
Go through the list of employees, find for the employee all data and copy it to his respective worksheet - which has already been created.
Here is the hardcoded version of the code:
ActiveSheet.Range("$A$1:$L$276").AutoFilter Field:=1, Criteria1:= _
"Employee name"
Range("A1").Select
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
Sheets("Employee name").Select
ActiveSheet.Paste
ActiveSheet.PageSetup.Orientation = xlPortrait
Columns("A:L").AutoFit
For Each r In Range("I:I").SpecialCells(xlCellTypeConstants)
r.Interior.ColorIndex = xlNone
If r.Value Like "*Home Office*" Then r.Interior.Color = vbGreen
If r.Value Like "*Neradni dan*" Then r.Interior.Color = vbRed
If r.Value Like "*Bolovanje*" Then r.Interior.Color = vbBlue
If r.Value Like "*Godišnji odmor*" Then r.Interior.ColorIndex = 29
Next
Columns("L").EntireColumn.Delete
Columns("J").EntireColumn.Delete
Columns("H").EntireColumn.Delete
Columns("C").EntireColumn.Delete
Columns("B").EntireColumn.Delete
Columns("G").EntireColumn.Delete
I copied the whole code below.
A clarification of what it needs to do:
sort the data in the first worksheet - already handled
create the worksheets by the names in the 3rd worksheet - working
On the first sheet, that is already "sorted" - I need to go through all the names, copy the the data that is relevant to the sheet - i.e the sheets are named by names that are found in row a. so i need it to go through the first worksheet, need all the data that has the same name in the row a and copy it to the respective sheet. - PLEASE HELP :)
Sub TEMPExcelObradiTablicuZaObracunPlaca()
'Convert Cell Format from Text to Date and change MDY to DMY Format
Sheets("Shifts").Select
Range("D2:D1000").Select
Selection.TextToColumns Destination:=Range("D2"), DataType:=xlFixedWidth, _
FieldInfo:=Array(0, 3), TrailingMinusNumbers:=True
Range("F2:F1000").Select
Selection.TextToColumns Destination:=Range("F2"), DataType:=xlFixedWidth, _
FieldInfo:=Array(0, 3), TrailingMinusNumbers:=True
'Ovdje dodajem potrebne Sheetove iz Members Sheeta
Sheets("Members").Select
Dim xRg As Excel.Range
Dim wSh As Excel.Worksheet
Dim wBk As Excel.Workbook
Set wSh = ActiveSheet
Set wBk = ActiveWorkbook
Application.ScreenUpdating = False
For Each xRg In wSh.Range("A2:A22")
With wBk
.Sheets.Add After:=.Sheets(.Sheets.Count)
ActiveCell.FormulaR1C1 = "Evidencija radnog vremena"
Selection.Font.Size = 20
Selection.Font.Bold = True
ActiveCell.Offset(1, 0).Range("A1").Select
ActiveCell.FormulaR1C1 = "Radnik"
Selection.Font.Size = 14
Selection.Font.Bold = True
ActiveCell.Offset(1, 0).Range("A1").Select
ActiveCell.FormulaR1C1 = "Godina i mjesec"
Selection.Font.Bold = True
ActiveCell.Offset(2, 0).Range("A1").Select
'Range("B2).Value = DateAdd(mmmm, yyyy) -> OVDJE SAM ZAPEO TU NASTAVITI!!! - dodavanje datuma u b2 celiju!
On Error Resume Next
ActiveSheet.Name = xRg.Value
Range("B2").Value = ActiveSheet.Name
If Err.Number = 1004 Then
Debug.Print xRg.Value & " already used as a sheet name"
End If
On Error GoTo 0
End With
Next xRg
Application.ScreenUpdating = True
'Sort by Date
Sheets("Shifts").Select
Range("A1").Sort Key1:=Range("D1"), Order1:=xlAscending, Header:=xlYes
'Define LASTROW to find the last row and column in Members Sheetu!
Dim LastRow As Long, LastColumn As Long
LastRow = Cells.Find(What:="*", After:=Range("A1"), SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
LastColumn = Cells.Find(What:="*", After:=Range("A1"), SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column
Range("A1").Resize(LastRow, LastColumn).Select
'Proba ForEach petlje
' Creating a range of sheet names from the data on Members
Dim SheetNamesRange As Range
Set SheetNamesRange = Sheets("Members").Range("A2:A" & LastRow)
' Iterate through all sheets in the range and write the word "Updated" in cell B2
Dim SheetName As Variant, SheetNameString As String
For Each SheetName In SheetNamesRange
' OVDJE SAM ISKOMENTIRAO OVA 2 REDA
'SheetNameString = CStr(SheetName)
'ThisWorkbook.Sheets(SheetNameString).Range("Q2") = "Updated"
Sheets("Shifts").Range("$A$1:$L$276").AutoFilter Field:=1, Criteria1:="SheetNameString"
Range("A1").Select
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
'SheetNameString = CStr(SheetName)
Sheets.CStr(SheetNameString).Select
ActiveSheet.Paste
ActiveSheet.PageSetup.Orientation = xlPortrait
Columns("A:L").AutoFit
For Each r In Range("I:I").SpecialCells(xlCellTypeConstants)
r.Interior.ColorIndex = xlNone
If r.Value Like "*Home Office*" Then r.Interior.Color = vbGreen
If r.Value Like "*Neradni dan*" Then r.Interior.Color = vbRed
If r.Value Like "*Bolovanje*" Then r.Interior.Color = vbBlue
If r.Value Like "*Godišnji odmor*" Then r.Interior.ColorIndex = 29
Next
Columns("L").EntireColumn.Delete
Columns("J").EntireColumn.Delete
Columns("H").EntireColumn.Delete
Columns("C").EntireColumn.Delete
Columns("B").EntireColumn.Delete
Columns("G").EntireColumn.Delete
Next SheetName
End Sub
You are right, a For Each loop can be used here. Here is some code that outlines the basic principle:
Private Sub Shone()
' Creating a range of sheet names from the data on Sheet1
Dim SheetNamesRange As Range
Set SheetNamesRange = ThisWorkbook.Sheets("Sheet1").Range("A1:A3")
' Iterate through all sheets in the range and write the word "Updated" in cell B2
Dim SheetName As Variant, SheetNameString As String
For Each SheetName In SheetNamesRange
SheetNameString = CStr(SheetName)
ThisWorkbook.Sheets(SheetNameString).Range("B2") = "Updated"
Next SheetName
End Sub
In this example, I want to grab the names of sheets written on Sheet1, and write the word "Updated" in cell B2 on each of those sheets.
The cells A1, A2, and A3 on the sheet Sheet1 contain the following text, respectively, "Sheet1", "Sheet2", "Sheet3". First, I create a Range of data. That data is just the sheet names in cells A1:A3. It goes without saying that your Range will contain different data, but I believe that you have already taken care of that part.
Next, I iterate through that Range of data. A For Each loop requires the iterator (in this case, the variable SheetName) to be a Variant datatype. As I iterate through all of the sheets, I finally get to what I want to do: write the word "Updated" in cell B2. Finally, we reach the Next statement which tells us that the next step of the For Each loop will start, if there are any more members in the SheetNamesRange to iterate through.

Why does this show errors when it was working

Code at the bottom
Hi, I just got this macro to repair. People tell me that it was working before.
This macro is supposed to copy only the visible filtered data (dynamic tables mainly) and create a new excel file with all the same worksheets but with only the visible data copied and paste in them (worksheets) with no dynamic table. This is meant to reduce the weight of the file but not to make an exact copy.
You are supposed to open this file with the one you want to transfer data and you run the macro in the files you want to copy.
First there were methods errors with 'Sheets(Pages).Select' (I switched from .Activate) and it worked.
After that 'NewBook.Sheets(1).Range("A1:BZ500").Select' were methods errors for range, so I split it in two lines:
'NewBook.Sheets(1).activate'
'Range("A1:BZ500").Select'
This resolved that error.
After that, there is a name attribution error (like the name is already used) to the line:
NewBook.Sheets(1).Name = OldBook.Sheets(Page).Name ( i tried a spy but ieverything was ok) so I decided to write it like NewBook.Sheets(1).Name = OldBook.Sheets(Page).Name + Cstr(Page)
It resolved the error but the macro is still not doing what it's meant to:
Set OldBook = ActiveWorkbook
Set NewBook = Workbooks.Add
NewBook.Worksheets(1).Name = "Vide"
OldBook.Activate
For Page = 1 To Sheets.Count - 1
OldBook.Activate
Sheets(Page).Activate
Sheets(Page).Copy Before:=NewBook.Sheets(1)
NewBook.Activate
NewBook.Sheets(1).Name = OldBook.Sheets(Page).Name
NewBook.Sheets(1).Range("A1:BZ500").Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Next
End Sub
Below is the one with my corrections:
Sub Fichier_Plat()
Code_optimizer (True)
Set OldBook = ActiveWorkbook
Set NewBook = Workbooks.Add
NewBook.Worksheets(1).Name = "Vide"
OldBook.Activate
For Page = 1 To Sheets.Count - 1
OldBook.Activate
Sheets(Page).Activate
Sheets(Page).Copy Before:=NewBook.Sheets(1)
NewBook.Activate
NewBook.Sheets(1).Name = OldBook.Sheets(Page).Name + CStr(Page)
NewBook.Sheets(1).Activate
Range("A1:BZ500").Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Next
Code_optimizer (False)
End Sub
I'd start by giving the original coder a hard slap for not defining the variables/not having 'Option Explicit' at the top of the module, for using Select and Activate and for hard-coding the range that's to be copied.
Maybe this code would be better?
Public Sub Fichier_Plat()
Dim OldBook As Workbook 'Declare your variables!
Set OldBook = ActiveWorkbook
Dim NewBook As Workbook
Set NewBook = Workbooks.Add(xlWBATWorksheet) 'Create new workbook with a single sheet.
NewBook.Worksheets(1).Name = "Vide"
Dim wrkSht As Worksheet
Dim newwrksht As Worksheet
For Each wrkSht In OldBook.Worksheets 'Look at each sheet in turn.
Set newwrksht = NewBook.Worksheets.Add
With newwrksht
.Name = wrkSht.Name 'Will cause error if one of them is called "Vide". Can use wrksht.Index to get number of sheet.
wrkSht.Range(wrkSht.Cells(1, 1), LastCell(wrkSht)).Copy
.Range("A1").PasteSpecial xlPasteValues
.Range("A1").PasteSpecial xlPasteFormats
End With
Next wrkSht
End Sub
Public Function LastCell(wrkSht As Worksheet) As Range
Dim LastCol As Long, LastRow As Long
On Error Resume Next
With wrkSht
LastCol = .Cells.Find("*", , , , xlByColumns, xlPrevious).Column
LastRow = .Cells.Find("*", , , , xlByRows, xlPrevious).Row
End With
If LastCol = 0 Then LastCol = 1
If LastRow = 0 Then LastRow = 1
Set LastCell = wrkSht.Cells(LastRow, LastCol)
End Function

VBA copy paste codes does not pasting anything

Can someone please let me know why my code is not pasting anything from my source data to my destination file?
The objectives of this code are to select rows that satisfy certain criteria, copy-pastes it into another workbook, The code is shown below:
Sub Copy_Source_LRE()
Dim LastRow As Integer, i As Integer, erow As Integer
Workbooks.Open _
"C:\Users\sjiang\OneDrive - Canada Pension Plan Investment Board\Desktop\IOA Exposure\AAPAF_strategy_loadings_2019-04-01_2020-04-01 (2).csv"
Worksheets("AAPAF_strategy_loadings_2019-04").Activate
Set sht = ActiveSheet
'Workbooks("AAPAF_strategy_loadings_2019-04-01_2020-04-01 (2).csv").Sheets("AAPAF_strategy_loadings_2019-04").Activate
LastRow = sht.Cells(sht.Rows.Count, "B").End(xlUp).Row
For i = 2 To LastRow
For Each d In Array("4/1/2019", "5/1/2019", "6/3/2019", "7/1/2019", "8/1/2019", "9/2/2019", _
"10/1/2019", "11/1/2019", "12/2/2019", "1/2/2020", "2/3/2020", "3/2/2020")
If Cells(i, 2) = d And Cells(i, 3) = "Real Estate" And Cells(i, 4) = "Listed Real Estate" And Cells(i, 5) = "AAPAF_SA" Then
Range(Cells(i, 2), Cells(i, 12)).Select
Selection.Copy
Workbooks.Open _
"C:\Users\sjiang\OneDrive - Canada Pension Plan Investment Board\Desktop\IOA Exposure\pull data.xlsm"
Worksheets("Sheet1").Select
erow = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
ActiveSheet.Cells(erow, 1).Select
ActiveSheet.Paste
ActiveWorkbook.Save
'ActiveWorkbook.Close
End If
Next d
Next i
Application.CutCopyMode = False
End Sub
This is a really easy and basic way that I use all the time to copy data into new workbooks. In this example I'm copying a named range called "MasterData" into a new blank workbook. Then I save that new book with a password and re-activate the current workbook.
Dim newfilename As String
newfilename = "/Users/" & userName & "/Desktop/savedWorkbook.xlsx"
Dim NewBook As Workbook
Set NewBook = Workbooks.Add
ThisWorkbook.Activate
Sheets("Datasheet").Select
Range("MasterData").Copy
NewBook.Activate
NewBook.Sheets(1).Select
Range("A1").Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
NewBook.SaveAs Filename:=newfilename, Password:="examplepassword", AccessMode:=xlExclusive, ConflictResolution:=Excel.XlSaveConflictResolution.xlLocalSessionChanges
NewBook.Close (True)
ThisWorkbook.Activate
I've redone the code for you as the major problem was related to a loop that is not really necessary. The best/fast way to apply those criteria and extract the data is using a filter to apply them, so copy the visible cells without the hidden (unmatching) lines and then open the second file where you need to past info, find next blank line below selection and paste all lines at once.
I'm pasting the code below (with comments) and also saved a zip file with 3 files (code, info, database) that might reflect your working files, link below.
VBS code:
Sub Copy_Source_LRE()
Dim LastRow As Integer, i As Integer, erow As Integer
Workbooks.Open ThisWorkbook.Path & "\" & "Wks1.xlsx" 'change the path and name here
Worksheets(1).Activate
Set sht = ActiveSheet
LastRow = Range("a1").SpecialCells(xlCellTypeLastCell).Row
datar = Range(Cells(LastRow, 12), Cells(1, 1)).Address 'data range
Range(datar).Select
Selection.AutoFilter 'create a filter,then use the criteria you need
ActiveSheet.Range(datar).AutoFilter Field:=2, Criteria1:= _
Array("4/1/2019", "5/1/2019", "6/3/2019", "7/1/2019", "8/1/2019", "9/2/2019", _
"10/1/2019", "11/1/2019", "12/2/2019", "1/2/2020", "2/3/2020", "3/2/2020"), Operator:=xlFilterValues 'your dates array can be update here
ActiveSheet.Range(datar).AutoFilter Field:=3, Criteria1:="Real Estate", Operator:=xlAnd
ActiveSheet.Range(datar).AutoFilter Field:=4, Criteria1:="Listed Real Estate", Operator:=xlAnd
ActiveSheet.Range(datar).AutoFilter Field:=5, Criteria1:="AAPAF_SA", Operator:=xlAnd
Range(datar).Offset(1, 0).Resize(Range(datar).Rows.Count - 1, Range(datar).Columns.Count).Select 'resize selection to remove the header
Selection.SpecialCells(xlCellTypeVisible).Select 'select visible cells only
Selection.Copy
Workbooks.Open ThisWorkbook.Path & "\" & "Wks2.xlsx" 'change the path and name here
Worksheets("Sheet1").Select
Range("A1").End(xlDown).Offset(1, 0).Select 'goes to the last row on column A the goes another one - 1st empty
ActiveSheet.Paste
ActiveWorkbook.Save
ActiveWorkbook.Close SaveChanges:=True 'close and save your database
Application.CutCopyMode = False
ActiveWorkbook.Close SaveChanges:=False 'close without saving your csv file
End Sub
link to files/code: https://drive.google.com/file/d/1zL_TwclHR4lrNhKB1xODGAmliPHM1r3K/view?usp=sharing
If the solution matches you need please consider as solution. Regards!

Cant write to cell

I am trying to get data from every other sheet in the workbook and paste it into a master sheet (Sheet1), but when I run my code nothing happens, Can someone tell me why this is?
Dim wb As Workbook
Dim ws As Worksheet
Set wb = ActiveWorkbook
wb.Sheets("Sheet1").Cells(1, 1).Text = "Started"
i = 1
'cells is row,col
For Each objWorksheet In wb.Worksheets
'ws.Cells(1, i).Value = objWorksheet.Name
'objWorksheet.Activate
'ws = wb.ActiveSheet
doJStuff i, objWorksheet
i = i + 1
Next
wb.Sheets("Sheet1").Cells(1, 1).Text = "DONE"
End Sub
Sub doJStuff(row, ws)
ws.Select
Range("A2").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Sheet1").Select
ActiveSheet.Cells(row, 1).Select
ActiveSheet.Paste
'end paste name
'copy post history and transpose into row 2 on sheet1
ws.Select
Range("H2:H30").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Sheet1").Select
ActiveSheet.Cells(row, 2).Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=True
'end post history
End Sub
You've got a number of problems with your code. First of all, avoid using Select wherever possible. Second, you are not properly assigning variables. You should put Option Explicit on the top of the module and then make sure you've assigned things correctly.
As for the actualy code, when you are copying/pasting the H2:H30 range into your first sheet you are going to only end up getting the first value in the range for every sheet except the last because you are pasting 28 rows but only incrementing the destination row by one. I didn't fix that but it's worth pointing out. I also left in your comments though they don't make much sense. Without knowing what you are trying to do, I've only cleaned up some of your code but it probably still won't work exactly right.
Sub YourSub()
Dim wb As Workbook
Dim wksht As Worksheet
Dim i As Integer
Set wb = ActiveWorkbook
wb.Sheets("Sheet1").Cells(1, 1).Text = "Started"
i = 1
'cells is row,col
For Each wksht In Worksheets
'ws.Cells(1, i).Value = objWorksheet.Name
'objWorksheet.Activate
'ws = wb.ActiveSheet
doJStuff i, wksht
i = i + 1
Next
wb.Sheets("Sheet1").Cells(1, 1).Text = "DONE"
End Sub
Sub doJStuff(row As Integer, ws As Worksheet)
ws.Range("A2").Copy
Sheets("Sheet1").Cells(row, 1).PasteSpecial
'end paste name
'copy post history and transpose into row 2 on sheet1
ws.Range("H2:H30").Copy
Sheets("Sheet1").Cells(row, 2).PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=True
'end post history
End Sub

how to create macro in a file in an excel changing dates

I'm creating a report everyday and the data needed are:
Open file #1 with file name: file1\today_23012015 for today.
In file #1 i need to get the items with yesterday's date which is 22012015 and copy those and paste it to the new workbook1.
Open file #2 with file name: file2\today_23012015 for today.
In file #2 I need to get the items with yesterday's date which is 22012015 and copy and paste to the sheet 2 of workbook1.
Can anyone help me create macro to this?
Sub Macro17()
'
' Macro17 Macro
'
'
Workbooks.Open Filename:="C:\Users\estillor\Desktop\file1240115.xlsx"
Windows("With macro.xlsm").Activate
Windows("file1240115.xlsx").Activate
ActiveCell.Offset(-8, -11).Range("A1").Select
Selection.AutoFilter
ActiveSheet.Range("$A$1:$D$24").AutoFilter Field:=4, Operator:= _
xlFilterValues, Criteria2:=Array(2, "1/23/2015")
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
Windows("With macro.xlsm").Activate
Sheets("Sheet1").Select
ActiveSheet.Paste
Windows("file1240115.xlsx").Activate
Windows("With macro.xlsm").Activate
Workbooks.Open Filename:="C:\Users\estillor\Desktop\file2240115.xlsx"
ActiveCell.Offset(-4, -16).Range("A1").Select
Application.CutCopyMode = False
Selection.AutoFilter
ActiveSheet.Range("$A$1:$D$10").AutoFilter Field:=4, Operator:= _
xlFilterValues, Criteria2:=Array(2, "1/23/2015")
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
Windows("With macro.xlsm").Activate
Sheets("Sheet2").Select
ActiveSheet.Paste
End Sub
This will be a process to get this working completely,
Practice with this code, adjust the folder locations and file names.
Once you get this to work for you, post back with a more detailed question.
Sub Do_Something_Cool()
Dim wb As Workbook, ws As Worksheet
Dim Bk As Workbook, sh As Worksheet
Dim dirt As String
Dim FnM As String
Dim FileNm As String
Dim Rws As Long, Rng As Range
dirt = "C:\Users\Dave\Downloads\"'adjust location
FnM = "file1240115.xlsx"
FileNm = dirt & FnM
Application.ScreenUpdating = 0
Set wb = Workbooks("WithMacro.xlsm")
Set ws = wb.Sheets("Sheet1")
Set Bk = Workbooks.Open(FileNm)
Set sh = Bk.Worksheets(1)
With sh
Rws = .Cells(Rows.Count, "A").End(xlUp).Row
.Range("A1").AutoFilter Field:=4, Criteria1:="=1/23/2015"
Set Rng = .Range(.Cells(2, "A"), .Cells(Rws, "D")).SpecialCells(xlCellTypeVisible)
Rng.Copy Destination:=ws.Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)
.AutoFilterMode = 0
Bk.Close True
End With
End Sub

Resources