VBA code to paste data from multiple workbooks into template by changing Pivot Fields - pivot-table

Wrote 3 different codes and Called them via Control Box in VBA, so now I've to select Root Account and Click One Button to create a report Single Account.
Is there a way to create such files for 50-100 accounts where all Root Account names are under Column J and Year under Column 2 (We've only 2 years, 2021 and 2022) but multiple account names in Column J
I've called all 4 Macros via Command Button, so now we've click only once to create file for one account but I need one click to create 100 accounts. Is it possible in any way.
Option Explicit
**'TO CHANGE PIVOT FIELDS (ROOT ACCOUNT & YEAR) IN ALL 4 MASTER FILES (ALL FILES HAVING MULTIPLE PIVOT TABLES AND ALL PIVOTS HAVING ACCOUNT NAME AND YEAR)**
Sub Account_Name_And_Year()
Dim workbookNames As Variant
workbookNames = Array("Boo1.xlsm", "Boo2.xlsm", "Boo3.xlsm", "Book4.xlsm") **'DEFINED WORKBOOK NAMES AS ARRAY**
Dim i As Long
For i = LBound(workbookNames) To UBound(workbookNames)
Dim wb As Workbook
Set wb = Workbooks(workbookNames(i))
Dim ws As Worksheet
Set ws = wb.Worksheets("Reports")
Dim rootAccount As String
rootAccount = ws.Cells(1, 10).Value **'IT'LL CHANGE PIVOT FIELD ROOT ACCOUNT AS CELL RANGE ("J1") IN ALL 4 FILES"**
Dim year As String
year = ws.Cells(1, 11).Value **'IT'LLL CHANGE PIVOT FIELD YEAR AS CELL RANGE ("K1") IN ALL 4 FILES"**
Dim pt As PivotTable
For Each pt In ws.PivotTables
With pt
With .PivotFields("Root Account") **'CHANGES PIVOT FIELD ROOT ACCOUNT ALL 4 MASTER FILES**
.CurrentPage = rootAccount
End With
With .PivotFields("Year") **'CHANGES PIVOT FIELD YEAR IN ALL 4 MASTER FILES**
.CurrentPage = year
End With
End With
Next pt
Next i
End Sub
**************************************************************************************************
**'ONCE PIVOT FIELDS (ROOT ACCOUNT & YEAR) CHANGES, COPY DATA FROM ALL PIVOT TABLES IN ALL 4 MASTER FILES AND PASTE IN TEMP FILE, SHEET 2021**
Sub Data_2021()
Dim Book1 As Workbook
Dim Book2 As Workbook
Dim Book3 As Workbook
Dim Book4 As Workbook
Dim Temp As Workbook
Set Book1 = Workbooks.Open("C:\New Folder\Boo1.xlsm")
Set Book2 = Workbooks.Open("C:\New Folder\Boo2.xlsm")
Set Book3 = Workbooks.Open("C:\New Folder\Boo3.xlsm")
Set Book4 = Workbooks.Open("C:\New Folder\Boo4.xlsm")
Set Temp = Workbooks.Open("C:\New Folder\Template_File.xlsm")
**'COPY DATA FROM ALL 4 WORKBOOKS AND PASTE IN DATA (2021) SHEET**
Book1.Sheets("Analysis").Range("A13:M71").Copy
Temp.Sheets("Data (2021)").Range("B4").PasteSpecial Paste:=xlPasteValues, operation:=xlNone, skipblanks _
:=True, Transpose:=False
Book2.Sheets("Analysis").Range("S17:W17").Copy
Temp.Sheets("Data (2021)").Range("Z21").PasteSpecial Paste:=xlPasteValues, operation:=xlNone, skipblanks _
:=True, Transpose:=False
Book3.Sheets("Analysis").Range("D12:H12").Copy
Temp.Sheets("Data (2021)").Range("Z36").PasteSpecial Paste:=xlPasteValues, operation:=xlNone, skipblanks _
:=True, Transpose:=False
Book4.Sheets("Analysis").Range("B5:B15").Copy
Temp.Sheets("Data(2021)").Range("X16").PasteSpecial Paste:=xlPasteValues, operation:=xlNone, skipblanks _
:=True, Transpose:=True
Workbooks("Boo1.xlsm").Activate
Sheets("Analysis").Activate
Range("K2").Activate
Cells(2, 11) = "2022"
End Sub""
**************************************************************************************************
**'THEN AGAIN RUN MACRO Account_Name_And_Year() TO CHANGE YEAR TO 2022 AND UPDATE ALL PIVOT TABLES IN ALL 4 MASTER FILES**
**'COPY DATA FROM ALL PIVOTS FROM ALL 4 MASTER FILES AND PASTE IN TEMP FILE, SHEET 2**
Sub Data_2022()
Dim Book1 As Workbook
Dim Book2 As Workbook
Dim Book3 As Workbook
Dim Book4 As Workbook
Dim Temp As Workbook
Dim FName As String
Dim Path As String
Application.DisplayAlerts = False
Set Book1 = Workbooks.Open("C:\New Folder\Boo1.xlsm")
Set Book2 = Workbooks.Open("C:\New Folder\Boo2.xlsm")
Set Book3 = Workbooks.Open("C:\New Folder\Boo3.xlsm")
Set Book4 = Workbooks.Open("C:\New Folder\Book4.xlsm")
Set Temp = Workbooks.Open("C:\New Folder\Template_File.xlsm")
Book1.Sheets("Analysis").Range("J1").Copy
Temp.Sheets("Data").Range("B1").PasteSpecial Paste:=xlPasteValues, operation:=xlNone, skipblanks _
:=True, Transpose:=False
Book2.Sheets("Analysis").Range("B17:B47").Copy
Temp.Sheets("Data").Range("T5").PasteSpecial Paste:=xlPasteValues, operation:=xlNone, skipblanks _
:=True, Transpose:=False
Book3.Sheets("Analysis").Range("B12:M12").Copy
Temp.Sheets("Data").Range("X37").PasteSpecial Paste:=xlPasteValues, operation:=xlNone, skipblanks _
:=True, Transpose:=False
Book4.Sheets("Analysis").Range("B5:B15").Copy
Temp.Sheets("Data").Range("X16").PasteSpecial Paste:=xlPasteValues, operation:=xlNone, skipblanks _
:=True, Transpose:=True
Range("A1").Activate
ActiveWorkbook.RefreshAll
Sheets("PPT").Activate
Range("A1").Activate
Path = "C:\New Folder\New folder\"
FName = Range("B1") & ".xlsm"
ActiveWorkbook.SaveAs Filename:=Path & FName
Sheets("PPT").Activate
Application.DisplayAlerts = True
MsgBox "COST ACTUALS REPORT IS CREATED FOR THIS ACCOUNT, PLEASE CLICK ON CREATE_PPT FOR POWERPOINT PRESENTATION"
Workbooks("Boo1.xlsm").Sheets("Analysis").Range("K1").Activate
End Sub

Related

Easier way of Importing data into excel - collections?

Is there an easier way of importing data into an excel array or other data structure? I've tried researching collections but I have found the documentation hard to comprehend.
http://www.functionx.com/vbaexcel/objects/Lesson6.htm
https://msdn.microsoft.com/en-us/library/f26wd2e5%28v=vs.100%29.aspx
The code I have below opens a select file and searches for the column header and then loops through each row storing the data according to header and row variables, I've done this method for many macros in the past but now I am dealing with many many columns and I'm looking for a more advanced way?
Sub Import_NAVRec()
MyPath = Range("b2") 'Defines cell that contains path to source file
Workbooks.Open (MyPath) 'Opens file
Set tempbook = ActiveWorkbook 'Names workbook
LR = Range("A65000").End(xlUp).Row 'finds last row in sourcefile
ReDim aNavRec(1 To LR, 1 To 4) 'Defines NAV Rec array
nRow = 0
cName = "Accounting Basis"
CA = Cells.Find(What:=UCase(cName), After:=ActiveCell, LookIn:=xlFormulas, LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext).Column
cName = "Accounting Date"
cB = Cells.Find(What:=UCase(cName), After:=ActiveCell, LookIn:=xlFormulas, LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext).Column
cName = "Asset Currency"
cC = Cells.Find(What:=UCase(cName), After:=ActiveCell, LookIn:=xlFormulas, LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext).Column
For r = 2 To LR
'If Cells(r, cB) = "Trading Gain Loss" Then
nRow = nRow + 1
aNavRec(nRow, 1) = Cells(r, CA) 'Fund Number
aNavRec(nRow, 2) = Cells(r, cB) 'Ledger
aNavRec(nRow, 3) = Cells(r, cC) 'Balance change
'End If
Next r
tempbook.Close
End Sub
Sub Print_output()
Sheets("Output").Select
Set Destination = Range("a2")
Destination.Resize(UBound(aNavRec, 1) + 1, UBound(aNavRec, 2)).Value = aNavRec
End Sub
The only thing we can help you eliminate is the for loop in the middle of you code. The rest seems to be necessary.
Option Explicit
Sub Import_NAVRec()
Dim LR As Long
Dim MyPath As String
Dim aNavRec As Variant 'Defines NAV Rec array
Dim tempbook As Workbook
Dim CA As Long, cB As Long, cC As Long
MyPath = Range("B2") 'Defines cell that contains path to source file
Workbooks.Open (MyPath) 'Opens file
Set tempbook = ActiveWorkbook 'Names workbook
LR = Range("A65000").End(xlUp).Row 'finds last row in sourcefile
cName = "Accounting Basis"
CA = Cells.Find(What:=UCase(cName), After:=ActiveCell, LookIn:=xlFormulas, LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext).Column
cName = "Accounting Date"
cB = Cells.Find(What:=UCase(cName), After:=ActiveCell, LookIn:=xlFormulas, LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext).Column
cName = "Asset Currency"
cC = Cells.Find(What:=UCase(cName), After:=ActiveCell, LookIn:=xlFormulas, LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext).Column
aNavRec = Application.Index(Range("A:AZ"), Application.Evaluate("Row(1:" & LR & ")"), Array(CA, cB, cC))
tempbook.Close
End Sub
With Option Explicit some more Dim were necessary (which I included in the above soluion).
Note: just found this solution here: use variable for row_num application.index

Using Checkboxes in Dialog Sheet to Specify Sheets to Perform Actions

I'm currently using the following code to reset an event/inventory/sales workbook. However, I was hoping to find a way to have the user select (via dialog sheet or userform with checkboxes) which sheets need to be reset. As it is right now, when the "Create New Event" button is clicked, every sheet in the sNames array is reset, but I would like for a dialog sheet or userform to popup which would allow the user to choose which sheets would be reset (aka... which ones that array would contain). So the sheets being reset would not be fixed and/or could be different each time the "Create new event" macro is run. In other words, the remaining code would stay the same, only the sheets included in the sNames array would change.
The full code that I have right now is as follows (Please note that this currently works, but the sheets being reset are fixed and/or are always the same)
Option Explicit
Sub Create_NewEvent()
Const DBLSPACE As String = vbNewLine & vbNewLine
Const BESTNFL As String = DBLSPACE & vbNewLine & _
"The Baltimore Ravens Rule!" & _
"The Forty-Winers Do NOT"
Const openMSG As String = "After pressing OK button this " & _
"will take some time." & DBLSPACE & "Amount of time " & _
"depends on whether or not the Ravens have a winning record," & _
"and whether or not..." & DBLSPACE & _
"Just be patient! Root for the Ravens and...!" & BESTNFL
Dim w As Long, I As Long, x As Long, sNames As Variant, invNames As Variant, colm As Range, tbl As Range, col1 As Range, invRng As Range
Dim wb As Workbook, ws As Worksheet, fbDate As Variant, fbEvent As Variant
Set wb = ThisWorkbook
'************************************IF YOU ADD A NEW STAND SHEET, PLEASE ADD THE SHEET NAME THIS ARRAY*********************************************************
sNames = Array(Sheet1, Sheet3, Sheet5, Sheet7, Sheet9, Sheet13, _
Sheet17, Sheet21, Sheet23, Sheet27, Sheet31, Sheet35, _
Sheet39, Sheet43, Sheet47, Sheet54, Sheet56, _
Sheet58, Sheet60, Sheet61, Sheet62, Sheet63, Sheet64, _
Sheet65, Sheet82, Sheet83, Sheet84, Sheet85, Sheet90, _
Sheet91, Sheet93, Sheet94)
'***************************************************************************************************************************************************************
'*************************IF YOU ADD A NEW NPO INVOICE, PLEASE ADD THE SHEET NAME & NUMBER IN THIS ARRAY********************************************************
invNames = Array(Sheet2, Sheet4, Sheet6, Sheet8, Sheet11, Sheet15, Sheet19, Sheet25, Sheet29, Sheet33, Sheet37, _
Sheet41, Sheet45, Sheet52, Sheet53, Sheet55, Sheet66, Sheet87)
'***************************************************************************************************************************************************************
If MsgBox("Are you sure that you want to create a new event?", vbYesNo, "Confirm") = vbYes Then
MsgBox openMSG
Application.DisplayAlerts = False
Application.ScreenUpdating = False
For w = LBound(sNames) To UBound(sNames)
With sNames(w)
Debug.Print .Name
.Range("D7:D38") = .Range("M7:M38").Value
Set tbl = .Range("B6:P38"): Set colm = .Range("M4")
ActiveWorkbook.Names.Add Name:="sTable", RefersTo:=tbl
ActiveWorkbook.Names.Add Name:="col", RefersTo:=colm
.Range("E7").Formula = "=IFERROR(IF(VLOOKUP(B7,sTable,3,FALSE)>=VLOOKUP(B7,parTable,col,FALSE),0,ROUND(SUM((VLOOKUP(B7,parTable,col,FALSE)-VLOOKUP(B7,sTable,3,FALSE))/VLOOKUP(B7,parTable,4,FALSE)),0)*VLOOKUP(B7,parTable,4,FALSE)),0)"
.Range("E7").Copy
.Range("E8:E38").PasteSpecial Paste:=xlPasteFormulas, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
.Range("E7:E38").Copy
.Range("E7:E38").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
.Range("G7:M38,P43:P45").ClearContents
ActiveWorkbook.Names("sTable").Delete
ActiveWorkbook.Names("col").Delete
Set tbl = Nothing: Set col1 = Nothing
End With
Next w
For I = LBound(invNames) To UBound(invNames)
With invNames(I)
Debug.Print .Name
Set invRng = .Range("B56:I56")
.Range("E55").Value = 0
For x = 1 To invRng.Cells.Count
invRng.Cells(x) = ""
Next x
Set invRng = Nothing
End With
Next I
fbDate = InputBox("Please enter the new event date in the format of 2/3/2013. This will be inserted onto the standsheets. And by the way... 2/3/2013 happens to be a past superbowl. Can you guess which one?")
fbEvent = InputBox("Please Enter the new event name. This will be inserted into the cell provided for Event Name")
Sheet49.Range("B3").Value = fbDate
Sheet49.Range("B4").Value = fbEvent
Application.DisplayAlerts = True
Application.ScreenUpdating = True
MsgBox "Your new event has been created...
End If
End Sub
Nevermind everyone.... Through a few hours of trial & error, I was able to get the following code to work perfectly... Not sure if I did this correctly (syntax, best practices, etc...), but it is definitely working exactly how I wanted it to...
Option Explicit
Sub Create_NewEvent()
Const DBLSPACE As String = vbNewLine & vbNewLine
Const BESTNFL As String = DBLSPACE & vbNewLine & _
"The Baltimore Ravens Rule!" & _
"The Forty-Winers Do NOT"
Const openMSG As String = "After pressing OK button this " & _
"will take some time." & DBLSPACE & "Amount of time " & _
"depends on whether or not the Ravens have a winning record," & _
"and whether or not..." & DBLSPACE & _
"Just be patient! Root for the Ravens and...!" & BESTNFL
Dim tPos As Integer, cb As CheckBox, SheetCount As Integer, sDlg As DialogSheet
Dim w As Long, I As Long, y As Variant, x As Long, z As Long, sNames As Variant, invNames As Variant, colm As Range, tbl As Range, col1 As Range, invRng As Range
Dim wb As Workbook, ws As Worksheet, fbDate As Variant, fbEvent As Variant
Set wb = ThisWorkbook
'************************************IF YOU ADD A NEW STAND SHEET, PLEASE ADD THE SHEET NAME THIS ARRAY*********************************************************
sNames = Array(Sheet1, Sheet3, Sheet5, Sheet7, Sheet9, Sheet13, _
Sheet17, Sheet21, Sheet23, Sheet27, Sheet31, Sheet35, _
Sheet39, Sheet43, Sheet47, Sheet54, Sheet56, _
Sheet58, Sheet60, Sheet61, Sheet62, Sheet63, Sheet64, _
Sheet65, Sheet82, Sheet83, Sheet84, Sheet85, Sheet90, _
Sheet91, Sheet93, Sheet94)
'***************************************************************************************************************************************************************
'*************************IF YOU ADD A NEW NPO INVOICE, PLEASE ADD THE SHEET NAME & NUMBER IN THIS ARRAY********************************************************
invNames = Array(Sheet2, Sheet4, Sheet6, Sheet8, Sheet11, Sheet15, Sheet19, Sheet25, Sheet29, Sheet33, Sheet37, _
Sheet41, Sheet45, Sheet52, Sheet53, Sheet55, Sheet66, Sheet87)
'***************************************************************************************************************************************************************
If MsgBox("Are you sure that you want to create a new event?", vbYesNo, "Confirm") = vbYes Then
MsgBox openMSG
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Set sDlg = ActiveWorkbook.DialogSheets.Add
SheetCount = 0
tPos = 40
For z = LBound(sNames) To UBound(sNames)
Set ws = sNames(z)
If Application.CountA(ws.Cells) <> 0 Then
SheetCount = SheetCount + 1
sDlg.CheckBoxes.Add 78, tPos, 150, 16.5
sDlg.CheckBoxes(SheetCount).Text = _
ws.Name
tPos = tPos + 13
End If
Set ws = Nothing
Next z
sDlg.Buttons.Left = 240
With sDlg.DialogFrame
.Height = Application.Max _
(68, sDlg.DialogFrame.Top + tPos - 34)
.Width = 230
.Caption = "Select Stands to Open"
End With
sDlg.Buttons("Button 2").BringToFront
sDlg.Buttons("Button 3").BringToFront
If SheetCount <> 0 Then
If sDlg.Show Then
For Each cb In sDlg.CheckBoxes
If cb.Value = xlOn Then
y = cb.Caption
With Sheets(y)
Debug.Print .Name
.Range("D7:D38") = .Range("M7:M38").Value
Set tbl = .Range("B6:P38"): Set colm = .Range("M4")
wb.Names.Add Name:="sTable", RefersTo:=tbl
wb.Names.Add Name:="col", RefersTo:=colm
.Range("E7").Formula = "=IFERROR(IF(VLOOKUP(B7,sTable,3,FALSE)>=VLOOKUP(B7,parTable,col,FALSE),0,ROUND(SUM((VLOOKUP(B7,parTable,col,FALSE)-VLOOKUP(B7,sTable,3,FALSE))/VLOOKUP(B7,parTable,4,FALSE)),0)*VLOOKUP(B7,parTable,4,FALSE)),0)"
.Range("E7").Copy
.Range("E8:E38").PasteSpecial Paste:=xlPasteFormulas, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
.Range("E7:E38").Copy
.Range("E7:E38").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
.Range("G7:M38,P43:P45").ClearContents
wb.Names("sTable").Delete
wb.Names("col").Delete
Set tbl = Nothing: Set col1 = Nothing
End With
End If
Next cb
End If
Else
MsgBox "All worksheets are empty."
End If
sDlg.Delete
For I = LBound(invNames) To UBound(invNames)
With invNames(I)
Debug.Print .Name
Set invRng = .Range("B56:I56")
.Range("E55").Value = 0
For x = 1 To invRng.Cells.Count
invRng.Cells(x) = ""
Next x
Set invRng = Nothing
End With
Next I
fbDate = InputBox("Please enter the new event date in the format of 2/3/2013. This will be inserted onto the standsheets. And by the way... 2/3/2013 happens to be a past superbowl. Can you guess which one?")
fbEvent = InputBox("Please Enter the new event name. This will be inserted into the cell provided for Event Name")
Sheet49.Range("B3").Value = fbDate
Sheet49.Range("B4").Value = fbEvent
Application.DisplayAlerts = True
Application.ScreenUpdating = True
MsgBox "Your new event has been created... Don't mess anything up today Mark! The Baltimore Ravens rule!!"
End If
End Sub

Using VBA to Loop through Array of Worksheet CodeNames

I am trying to loop through an array of specific worksheets via VBA, but keep getting errors. I've been at this for over a week now, and finally have brought myself to signup here. The code that I currently have is as follows:
Option Explicit
Sub Create_NewEvent2()
Dim i As Variant, wName As Variant, x As Variant, ws As Worksheet
wName = Array("Sheet1", "Sheet3", "Sheet5", "Sheet7", "Sheet9", _
"Sheet13", "Sheet17", "Sheet21", "Sheet23", "Sheet27", "Sheet31", _
"Sheet35", "Sheet39", "Sheet43", "Sheet47", "Sheet54", _
"Sheet56", "Sheet57", "Sheet58", "Sheet60", "Sheet61", "Sheet62", _
"Sheet63", "Sheet64", "Sheet65", "Sheet82", "Sheet83", "Sheet84", _
"Sheet85", "Sheet90", "Sheet91", "Sheet93", "Sheet94")
For Each ws In ActiveWorkbook.Worksheets
For i = LBound(wName) To UBound(wName)
If ws.CodeName = wName(i) Then
ws.Visible = xlSheetVisible
ws.Range("M7:M38").Select
Selection.Copy
ws.Range("D7").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
ws.Range("G7:M38,E7:E38,P43:P45").Select
ws.Range("P43").Activate
Selection.ClearContents
ws.Visible = xlSheetVeryHidden
Call AutoStock
End If
Next i
Next ws
End Sub
The error message that I got from this last piece of code is "Select Method of Range Class Failed." When I debug, it has the "ws.Range("M7:M38").Select" highlighted, but I've used this exact syntax in other pieces and worked just fine. Can anyone tell me where I've went wrong with this? Any help will be greatly appreciated..
See revised code with small modifications and comments.
I suggest not to use ActiveWorkbook as not necessarily is the one that you want to work with is active. Also there is no need to select the ranges you are working to (comments and documentation referred by #Jeeped)
Sub Create_NewEvent2_New()
Dim wName As Variant, vName As Variant
wName = Array("Sheet1", "Sheet3", "Sheet5", "Sheet7", "Sheet9", _
"Sheet13", "Sheet17", "Sheet21", "Sheet23", "Sheet27", "Sheet31", _
"Sheet35", "Sheet39", "Sheet43", "Sheet47", "Sheet54", _
"Sheet56", "Sheet57", "Sheet58", "Sheet60", "Sheet61", "Sheet62", _
"Sheet63", "Sheet64", "Sheet65", "Sheet82", "Sheet83", "Sheet84", _
"Sheet85", "Sheet90", "Sheet91", "Sheet93", "Sheet94")
Dim Wbk As Workbook 'Set workbook variable don't use ActiveWorkbook
Dim ws As Worksheet
Rem Set Workbook - Change as needed if applied to another workbook.
Set Wbk = ThisWorkbook
Rem Loop thru List of Worksheets instead of All Worksheets
For Each vName In wName
Set ws = Nothing
On Error Resume Next
Set ws = Wbk.Worksheets(vName)
On Error GoTo 0
If Not (ws Is Nothing) Then
With ws
.Visible = xlSheetVisible
.Range("M7:M38").Copy
.Range("D7").PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
.Range("G7:M38,E7:E38,P43:P45").ClearContents
.Visible = xlSheetVeryHidden
End With
Call AutoStock
End If: Next
End Sub
The Worksheet.CodeName actually returns a Worksheet object. You can construct your array with them directly.
Sub Create_NewEvent2()
Dim w As Long, vCODENAMEs As Variant
vCODENAMEs = Array(Sheet1, Sheet3, Sheet5, Sheet7, Sheet9, Sheet13, _
Sheet17, Sheet21, Sheet23, Sheet27, Sheet31, Sheet35, _
Sheet39, Sheet43, Sheet47, Sheet54, Sheet56, Sheet57, _
Sheet58, Sheet60, Sheet61, Sheet62, Sheet63, Sheet64, _
Sheet65, Sheet82, Sheet83, Sheet84, Sheet85, Sheet90, _
Sheet91, Sheet93, Sheet94)
For w = LBound(vCODENAMEs) To UBound(vCODENAMEs)
With vCODENAMEs(w)
Debug.Print .Name 'string name of the worksheet
' all of your other operations here
'.Visible = xlSheetVisible 'you do not have to unhide for the operations you've chosen if you reference directly
.Range("D7:D38") = .Range("M7:M38").Value
.Range("E7:E38,G7:M38,P43:P45").ClearContents
.Visible = xlSheetVeryHidden
Call AutoStock
End With
Next w
End Sub
With direct worksheet and cell referencing, I've completely avoided all of the .Activate and .Select nonsense. See How to avoid using Select in Excel VBA macros for more methods on getting away from relying on select and activate to accomplish your goals.
Select does not work on a worksheet that is not active.
Call ws.Activate first and then Select should work.

An Excel macro that can add and populate a new row to a separate worksheet using data from two columns

What I am trying to do is this.
I have a customer information form, with information stored on the 1st sheet in two columns, the range is F5:F38,M5:M33
I have an empty database on worksheet2 that i'd like to populate with this data, Starting on C5 across to BM5
I want to be able to assign the macro to an 'add' button, and have the macro automatically insert a new row for the data and copy it across, enabling users to use worksheet1 to populate!
Matt
Updated from David's advice thus far. The only outstanding issue is that when running the script, Column M has the marching ants but the data itself does not copy across. For further clarity, the sheet has data validation and some conditional formatting (a few drop-down options and some colour coding on Y/N answers), i'm not sure if this is a factor.
Dim wsDB As Worksheet
Dim wsInfo As Worksheet
Sub Main()
Set wsDB = Worksheets("DATABASE")
Set wsInfo = Worksheets("INPUT")
insertnewrow
addcolumnf
addcolumnm
End Sub
Sub insertnewrow()
'
' insertnewrow Macro
wsDB.Rows("6:6").Insert _
Shift:=xlDown, _
CopyOrigin:=xlFormatFromLeftOrAbove
End Sub
Sub addcolumnf()
'
' addcolumnf Macro
wsInfo.Range("F5:F38").Copy
wsDB.Range("C6:AJ6").PasteSpecial _
Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=True
End Sub
Sub addcolumnm()
'
' addcolumnm Macro
'
Application.CutCopyMode = False
wsInfo.Range("M5:M33").Copy
wsDB.Range("AK6:BM6").PasteSpecial _
Paste:=xlAllExceptBorders, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=True
End Sub
OK. I am not exactly sure what your problem is but likely related to unqualified object variables. When you do something like:
Range("A1").Select
Excel always interprets that as belonging to the ActiveSheet object. Since you are relying on the Selection method, it becomes difficult to track what is happening, you need to constantly select new objects to scope everything properly, etc.
This can be avoided by revising your code to something like:
Dim wsDB As Worksheet
Dim wsInfo As Worksheet
Sub Main()
Set wsDB = Worksheets("Database")
Set wsInfo = Worksheets("Sheet3") 'MODIFY AS NEEDED
insertnewrow
addcolumnf
addcolumnm
End Sub
Sub insertnewrow()
'
' insertnewrow Macro
wsDB.Rows("6:6").Insert _
Shift:=xlDown, _
CopyOrigin:=xlFormatFromLeftOrAbove
End Sub
Sub addcolumnf()
'
' addcolumnf Macro
wsInfo.Range("F5:F38").Copy
wsDB.Range("C6:AJ6").PasteSpecial _
Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=True
End Sub
Sub addcolumnm()
'
' addcolumnm Macro
'
Application.CutCopyMode = False
wsInfo.Range("M5:M33").Copy
wsDB.Range("AK6:BM6").PasteSpecial _
Paste:=xlAllExceptBorders, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=True
End Sub
After I run this a few times, my "Database" worksheet looks like the image below. Simply call the Main routine which fires the other three. It will always insert a blank row in row 6, and it will always copy columns F and M in to that new row.
I suggest you get started with a tool included in Microsoft Excel called "Data Form". Add it into the menu and use it. An important thing is that you need reorganize your data: In the first line put the header (e.g begin in A1 to A...) and data in next lines. This organzation will help you to exploit your information using Pivot tables.
If you prefer use a button to call the form, you can use this macro assigned to a button:
Sub Macro1()
Sheets("worksheet1").Select
Range("A1").Select
ActiveSheet.ShowDataForm
End Sub
This link will show you more about that tool:
http://www.homeandlearn.co.uk/excel2007/excel2007s8p1.html
If you have knowledge of programming I could show you how to do what you want using VBA in Excel (for, while, etc). It is a little more complicated.
Here the code that you need. but is necesary that C5 in sheet2 is nt empty:
Sub Macro6()
Dim Count As Long
'Copy first column
Sheets("worksheet1").Select
Range("F5:F38").Select
Selection.Copy
'Search the next row empty
Sheets("worksheet2").Select
Range("C5").Select
Selection.End(xlDown).Select
Count = ActiveCell.Cells.Row + 1
'Copy in the next empty row
Range("C" & Count).Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=True
'Again with the next column
'Copy second column
Sheets("worksheet1").Select
Range("M5:M33").Select
Application.CutCopyMode = False
Selection.Copy
'Copy in the same row in the second sheet
Sheets("worksheet2").Select
Range("AK" & Count).Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=True
End Sub

VBA put data from file to Excel Sheets

I got file.txt structure like this:
"FIRST"
a1 b1 c1 d1
a2 b2 c2 c2
"SECOND"
e1 f1
e2 f2
"THIRD"
g1 h1
I got three sheets in my Excel file: "first", "second" and "third". How to populate this data into three sheets by VBA code?
I still think that reading a text file line per line is the best way to go.
You can load the entire file into an array and write conditions later.
Sub Read_text_File()
Dim oFSO As New FileSystemObject
Dim oFS
Dim sText as String
Dim vArray
Dim lCnt as Long
Set oFS = oFSO.OpenTextFile("c:\textfile.TXT")
Do Until oFS.AtEndOfStream
lCnt = lCnt + 1
sText = oFS.ReadLine
vArray(lCnt) = sText
Loop
End Sub
Then look through the array and do your stuff.
Or you could load the data in three separate arrays immediately, representing the three sheets.
This is entirely up to you.
Let me know if this was helpful.
Start recording a macro and open the txt file delimited by space. press ctrl + f and find First, Second and Third in three steps. copy your required range from the active workbook to your required workbook in respective sheets.
this will give you a recorded macro which you can restructure to make an automated code. Maybe i can post some code later. you will have to add lines of vba to read the line numbers of the cells used to find secon and third so that you know what range you have to copy.
1 question, number of columns in your file is as shown????
here is a code.
Sub Macro1()
Dim startRow As Integer
Dim endRow As Integer
Dim wb As Workbook
Workbooks.OpenText Filename:="D:\file.txt", Origin:=437, startRow:=1, _
DataType:=xlDelimited, TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter _
:=True, Tab:=True, Semicolon:=False, Comma:=False, Space:=True, Other _
:=False, FieldInfo:=Array(Array(1, 1), Array(2, 1), Array(3, 1), Array(4, 1)), _
TrailingMinusNumbers:=True
Set wb = ActiveWorkbook
Cells.Find(What:="FIRST", After:=ActiveCell, LookIn:=xlFormulas, LookAt _
:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
False, SearchFormat:=False).Activate
startRow = ActiveCell.Row + 1
Cells.Find(What:="SECOND", After:=ActiveCell, LookIn:=xlFormulas, LookAt _
:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
False, SearchFormat:=False).Activate
endRow = ActiveCell.Row - 1
Range("A" & startRow & ":D" & endRow).Copy
ThisWorkbook.Activate
Sheets("Sheet1").Select
Range("A1").Select
ActiveSheet.Paste
startRow = endRow + 2
wb.Activate
Cells.Find(What:="THIRD", After:=ActiveCell, LookIn:=xlFormulas, LookAt _
:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
False, SearchFormat:=False).Activate
endRow = ActiveCell.Row - 1
Range("A" & startRow & ":D" & endRow).Copy
ThisWorkbook.Activate
Sheets("Sheet2").Select
Range("A1").Select
ActiveSheet.Paste
wb.Activate
startRow = endRow + 2
endRow = Range("A" & Rows.Count).End(xlUp).Row
Range("A" & startRow & ":D" & endRow).Copy
ThisWorkbook.Activate
Sheets("Sheet3").Select
Range("A1").Select
ActiveSheet.Paste
wb.Close (False)
End Sub

Resources