Iam a DB Guy and i dont know anything about VB.
I have a Macro in Excel and in Excel i have cross tabular records.
My macro will convert Crosstabular records to tabular records.
But My requirement is i want to Run the Same Macro outside the excel.
.VBS file should be there and whenever we run the .VBS it should pick excel from some place and convert the crosstab records to tabular records and save at some different location.
I have created a Code for the same by googling and Somebody Please review my below code and help me with the Proper code.
Sub RunMacro()
Dim xlApp 'As Excel.Application
Dim xlBook 'As Workbook
Dim xlSheet 'As Worksheet
Dim wsCrossTab 'As Worksheet
Dim wsList 'As Worksheet
Dim iLastCol 'As Long
Dim iLastRow 'As Long
Dim iLastRowList 'As Long
Dim rngCTab 'As Range 'Used for range in Sheet1 cross tab sheet
Dim rngList 'As Range 'Destination range for the list
Dim I 'As Long
Set xlApp = CreateObject("Excel.Application")
Set xlBook = xlApp.Workbooks.Open("D:\Source.xls")
CrossTabToList()
xlBook.SaveAs "D:\Results.xls"
xlApp.Quit
End Sub
Sub CrossTabToList()
Set wsCrossTab = Worksheets("Tabular")
Set wsList = Worksheets.Add
'Find the last row in Sheet1 with the cross tab
iLastRow = wsCrossTab.Cells(Rows.Count, "A").End(xlUp).Row
'Set the initial value for the row in the destination worksheet
iLastRowList = 2
'Find the last column in Sheet1 with the cross tab
iLastCol = wsCrossTab.Range("A8").End(xlToRight).Column
'Create a new sheet and set the heading titles
wsList.Range("A1:C1") = Array("CATEGORY", "SUBCATEGORY", "VALUE")
'Start looping through the cross tab data
For I = 2 To iLastRow
Set rngCTab = wsCrossTab.Range("A" & I) 'initial value A2
Set rngList = wsList.Range("A" & iLastRowList) 'initial value A2
'Copy individual names in Col A (A2 initially) into as many rows as there are data columns in the cross tab (less 1 for Col A).
rngCTab.Copy rngList.Resize(iLastCol - 1)
'Move up a I rows less one and across one column (using offset function) to select heading row. Copy.
rngCTab.Offset(-(I - 1), 1).Resize(, iLastCol - 1).Copy
'Paste transpose to columns in the list sheet alongside the names
rngList.Offset(0,1).PasteSpecial Transpose:=True
'Staying on same row (2 initially) copy the data from the cross tab
rngCTab.Offset(, 1).Resize(, iLastCol - 1).Copy
'Past transpose as column in list sheet
rngList.Offset(0, 2).PasteSpecial Transpose:=True
'Set the new last row in list sheet to be just below the last name copied
iLastRowList = iLastRowList + (iLastCol - 1)
'increment I by 1
Next I
Application.DisplayAlerts = False
Sheets("Tabular").Select
ActiveWindow.SelectedSheets.Delete
Application.DisplayAlerts = True
Sheets("Sheet1").Select
Sheets("Sheet1").Name = "Results"
objwkbk.SaveAs "D:\Results.xls"
End Sub
Thanks,
Praveen
As i mentioned i am not a Java Developer or Coding guy,i am a Database person ,i dont know anything about Java .I want to use the above code as .VBS file.I want somebody to correct my above code to use it in a .VBS File.If you can do that it will be really appreciated.
Thanks in Advance.
That's a very good idea. VBA in an Excel file can confuse users, so I try to avoid that whenever possible.
I recommend storing your procedure in an Access file. There's a little work involved in converting it, but this should get you started:
Make a new Access db
In your new db, make a new VBA module. Paste your code in there.
Add your most current version of Microsoft Excel Object Library.
Make whatever other changes are necessary to get the code in working order again (you'll have to do a bit of trial and error. Run the code repeatedly and deal with the error messages as they pop up)
Change your Sub to a Function (you need to do this to call it from a Macro)
Make a new Macro. Add the action RunCode with the argument RunMacro()
In the future, all you will have to do is open the db and click on the macro to run the code.
Related
I have a workbook that serves as a database with an Input page. I want to make Column A dynamic, which will update header rows on all pages of the worksheet. I have created a macro that copies these header names from Column A on the Input Sheet, and pastes these values as headers on the next sheet. Once these header rows are labeled they are copied on Sheet 2 a second time so they can be pasted as additional header rows to the right of the previously pasted values. The reason is because they are values monitored at Start and Stop times, which will have different data stored at each time. Also, I would like these header rows to have medium weight borders around them. I have drafted the following code, but it only works partially correct by copying the first set as expected, however the second copy part does not work as well. I was hoping to create a template sheet in the document, which would have Date, Start Time, Space, End time. This would mean the copy rows would need to be inserted after Start Time and again after End time in a dynamic manner so this list could grow. Please see my attached code and thank you so much for any help.
Sub CopyData2()
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim wb As Workbook
Dim lRow As Long
Dim lCol1 As Long
Dim lCol2 As Long
Dim cRange As Range
Dim iCell As Range
Dim iRange As Range
Set wb = ThisWorkbook
Set ws1 = wb.Sheets(1)
Set ws2 = wb.Sheets(2)
lRow = ws1.Cells(Rows.Count, 1).End(xlUp).Row
lCol1 = ws2.Cells(12, Columns.Count).End(xlToLeft).Column
lCol2 = ws2.Cells(3, Columns.Count).End(xlToLeft).Column
ws1.Range("A13:A" & lRow).Copy
ws2.Range("C3").PasteSpecial xlPasteValues, Transpose:=True
Set cRange = ws2.Range(("C3"), ws2.Range("C3").End(xlToRight))
cRange.Select
cRange.Copy
ws2.Cells(3, lCol2).PasteSpecial xlPasteValues
End Sub
I'd suggest replacing the last 4 lines with those below
With ws2.Range(("C3"), ws2.Range("C3").End(xlToRight))
ws2.Cells(3, lCol2).Resize(.Rows.Count,.Columns.Count).Value2 = .Value2
End With
in order to avoid both the Select, and redundant use of the clipboard.
I don't understand what you're trying to do with the Start/Stop times but the try removing cRange.Select to fix the 2nd Copy/Paste
I run an audit at work which can return several million line items of data. So excel gives me many tabs of 65,536 line items on each tab. I have the vba code which will combine all data onto one tab but again this won't work because of the row limits for each tab. Therefore I only want certain line items being pulled out.
I only want to include the line items where the Field Name is Position is Using Time. I am new to VBA and assume that I should specify that within the Loop?
So (within the code listed below) I need to include For every time the Field Name equals Position is Using Time I want that entire line item to be dropped into the new Audit Trail tab. I have included an example of the line item I am looking for within each tab, and also a copy of the code I use for combining smaller audit trails.
Any help is very much appreciated! Thank you.
Example of line item I need to pull from the data
Sub CopyFromWorksheets()
Dim wrk As Workbook 'Workbook object
Dim sht As Worksheet 'Object for handling worksheets in loop
Dim trg As Worksheet 'Audit Trail Worksheet
Dim rng As Range 'Range object
Dim colCount As Integer 'Column count in tables in the worksheets
Set wrk = ActiveWorkbook 'Working in active workbook
'Add new worksheet as the last worksheet
Set trg = wrk.Worksheets.Add(After:=wrk.Worksheets(wrk.Worksheets.Count))
'Rename the new worksheet
trg.Name = "Audit Trail"
'Get column headers from the first worksheet
'Column count first
Set sht = wrk.Worksheets(1)
colCount = sht.Cells(1, 255).End(xlToLeft).Column
'Retrieve Headers
With trg.Cells(1, 1).Resize(1, colCount)
.Value = sht.Cells(1, 1).Resize(1, colCount).Value
'Set font as bold
.Font.Bold = True
End With
'Start loop
For Each sht In wrk.Worksheets
'If worksheet in loop is the last one, stop execution (it is Master worksheet)
If sht.Index = wrk.Worksheets.Count Then
Exit For
End If
'Data range in worksheet - starts from 1st row as headers are only in first tab.
Set rng = sht.Range(sht.Cells(1, 1), sht.Cells(65536, 1).End(xlUp).Resize(, colCount))
'Put data into the Master worksheet
trg.Cells(65536, 1).End(xlUp).Offset(1).Resize(rng.Rows.Count, rng.Columns.Count).Value = rng.Value
Next sht
'Fit the columns in Master worksheet
trg.Columns.AutoFit
End Sub
The 64K row limit went away with Excel 2007. It's over a million rows since that version. With Power Pivot (XL 2010 and later), you can load a LOT more rows than that into the data model. Looping through all that data with VBA will be painfully slow. Using modern tools like Power Query, you can combine the data from all sheets and set filters. That will run a LOT faster.
I'm trying to open a sheet (Archive) from my inventory sheet, filter the data in the second sheet and then copy the filtered data to a sheet on the inventory. Everything is working except that the filtered data only copies the data from rows in the first contiguous range. My code is as follows
Dim LastRow As Long
Dim nOoFrOWS As Long
Dim oSht As Worksheet
Workbooks.Open ("C:\Inventory\Archive.xlsm") '<- at opening a workbook it becomes the active one
Set oSht = ActiveWorkbook.Worksheets("Archive") '<-- set the destination worksheet in the activeworkbook
With ActiveSheet
.ListObjects("Archive").Range.AutoFilter Field:=12, Criteria1:=mOrder
nOoFrOWS = .AutoFilter.Range.Columns(1).SpecialCells(xlCellTypeVisible).Cells.Count - 1 '# of rows in Inventory
End With
Unload Me
ThisWorkbook.Sheets("RAM").Range("A2:K" & nOoFrOWS).Value = oSht.Range("Archive[[QTY]:[RTK]]").SpecialCells(xlCellTypeVisible).Cells.Value
oSht.Parent.Close False
What am I doing wrong?
edit: I don't know if it is pertinent, but the range in the archive (from which I am copying) is not the entire table. I have more rows, but These are all I need for this application.
Also, is there a way to do this without the clipboard by using .value or am I stuck with using the copy paste method?
As your working with a table you can copy the visible cells in the databodyrange.
No need to activate or select anything - just work with the referenced files & sheets.
Sub Test()
Dim wrkBk As Workbook
Dim mOrder As Long
mOrder = 5
'You can reference the workbook without it being active.
Set wrkBk = Workbooks.Open("C:\Inventory\Archive.xlsm")
With wrkBk.Worksheets("Archive").ListObjects("Archive")
.Range.AutoFilter Field:=12, Criteria1:=mOrder
'Copy the DataBodyRange (Range would include the headers).
.DataBodyRange.Resize(, 11).SpecialCells(xlVisible).Copy Destination:=ThisWorkbook.Worksheets("RAM").Range("A2")
End With
End Sub
Please help!
The last line of my code
'Sheets("Original Data from Server").Cells(4, 2).Select
Will not work! Keep getting error "Select method of range class failed'
Whenever I only run that one line, it works perfect.
But whenever I run the rest of the code, I get the error.
NO ONE can seem to help me figure this out!
Sub FormatAdjacencyReport()
Dim iLastRow As Integer '<-- Interger for Counting Number of Rows
Dim iLastColumn As Integer '<-- Interger for Counting Number of Columns
Dim OriginalOutput As Worksheet '<-- Sheet Containing Orignal Report
Dim AdjacencyData As Worksheet '<-- Sheet Crated for Final Output
Set OriginalOutput = ActiveWorkbook.Worksheets(1)
OriginalOutput.Name = "Original Data from Server"
'Determines how many different rows we have in original output
iLastRow = Range("B1").Rows.End(xlDown).Row
'Txt to Columns for Each Row
For i = 2 To iLastRow
Sheets("Original Data from Server").Cells(i, 5).TextToColumns DataType:=xlDelimited, _
ConsecutiveDelimiter:=True, Space:=True
Next i
'Create a new sheet for our output
Set AdjacencyData = Sheets.Add
AdjacencyData.Name = "Adjacency Data Output"
'Need to Paste the Entire List of Store Numbers into a New Tab
iLastColumn = Sheets("Original Data from Server").Cells(2, 1).Columns.End(xlToRight).Column
'Sheets("Original Data from Server").Cells(4, 2).Select
End Sub
You need to set focus back on Sheets("Original Data from Server") before calling a select on that sheet. So put line 'Sheets("Original Data from Server").Select before the last line. When the line throwing error is being executed, the focus is on another sheet.
To avoid this kind of errors I suggest you stop working with select and/or activate generally, and only use it when absolutely necessary.
Your code could look like this:
Sub FormatAdjacencyReport()
Dim iLastRow As Long '<-- for Counting Number of Rows
Dim iLastColumn As Long '<-- for Counting Number of Columns
Dim OriginalOutput As Worksheet '<-- Sheet Containing Orignal Report
Dim AdjacencyData As Worksheet '<-- Sheet Crated for Final Output
Set OriginalOutput = ActiveWorkbook.Worksheets(1)
OriginalOutput.Name = "Original Data from Server"
'Determines how many different rows we have in original output
iLastRow = OriginalOutput.Range("B1").End(xlDown).Row ' changed
iLastColumn = OriginalOutput.Range("A2").End(xlToRight).Column ' changed
'Txt to Columns for Each Row
For i = 2 To iLastRow
OriginalOutput.Cells(i, 5).TextToColumns DataType:=xlDelimited, _
ConsecutiveDelimiter:=True, Space:=True
Next i
'Create a new sheet for our output
Set AdjacencyData = Sheets.Add
AdjacencyData.Name = "Adjacency Data Output"
'Need to Paste the Entire List of Store Numbers into a New Tab
' OriginalOutput.Activate -- not needed
' OriginalOutput.Cells(4, 2).Select -- not needed
OriginalOutput.Range("B4:B17").Value = AdjacencyData.Range("A10:A23") ' direct copy!
End Sub
1- work with qualified ranges/cells whenever you work on more than one sheet or workbook. See the line where iLastRow is determined.
2- keep table limit calculation in one place (as soon as the limits are fixed)
3- avoid an explict qualifier (Sheets("Original Data from Server").) in favor of the assigned variable (OrignalOutput). This way you can fully qualify (with workbook name and sheet name) in just one place. Imagine you'd change the sheet name later...
4- use direct assignment from range to range for copying. This circumvents the reference problem (if using qualifiers!), and the clipboard contents are kept intact.
Currently I have spreadsheets coming in that are formatted incorrectly. Our client sent out to his suppliers an old spreadsheet where columns are laid out differently than what they are currently setup as. Normally we would tell them to correct it, but some of these spreadsheets have over 220k rows and 33 columns. They're updating it for the future, but asking them to have their clients redo their tables is a no-go. I've written a script that will copy a column, and place it into the corresponding static column in another workbook. This works okay but I feel there is more that could be done.
Name of open workbook copying from varies.
Name of workbook copied to: C:\User\(Name)\UCOR\Catalogs\PSX-Toolset v1.503-EN.xls
What I would like is help writing a macro that will do the following from open workbook:
1.) Select an entire column minus Row 1 to the first blank row. - This goes from B to AH
2.) Paste that column into PSX-Toolset workbook, worksheet name "Item Data" - Static Assigned Columns
3.) Perform a Save As on PSX-Toolset as (Catalog-PSX-<Workbook Copied From>.xls)
Lastly, I'd like to know if it's possible to do the above, but mapping heading cells. Unfortunately the cell names are not identical.
Untested:
Sub MapAndCopyColumns()
Dim i As Integer, rng As Range
Dim shtSrc As Worksheet, wbDest As Workbook
Dim shtDest As Worksheet
Dim iNew
Set shtSrc = ActiveSheet
Set wbDest = Workbooks.Open("C:\User\(Name)\UCOR\Catalogs\PSX-Toolset v1.503-EN.xls")
Set shtDest = wbDest.Sheets("Item Data")
For i = 2 To 34
Set rng = shtSrc.Cells(2, i)
If rng.Value <> "" Then
If rng.Offset(1, 0).Value <> "" Then
Set rng = Range(rng, rng.End(xlDown))
End If
'map old position >> new position
' mapping table has 2 columns of numbers: "old" and "new"
iNew = Application.VLookup(i, _
ThisWorkbook.Sheets("Mapping").Range("A2:B40"), 2, False)
If Not IsError(iNew) Then
'copy if the column has an entry in the mapping table
rng.Copy shtDest.Cells(2, iNew)
End If
End If
Next i
wbDest.SaveAs "C:\wheretosaveto\Catalog-PSX-" & shtSrc.Parent.Name
End Sub
How I learned most of my vba is through 'record macro'. You start recording, do what you want to do yourself, stop recording and then look at the generated code.
Usually you can improve the code by eliminating a lot of redundant lines, but it should at least expose all the commands you need to complete your goal.