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.
Related
I have a spreadsheet that operators input data in, with the A column being the date, and the data is input by row. The A column is a formula that adds +1 to the date in the previous cell, going all the way down recursively to auto-populate the date as the sheet is filled out.
I have to have a report printed out at the end of every day, and I am trying to use VBA to filter the rows out by a date that the operator inputs on another sheet in cell B2. I need the macro to grab that date value, and pass it as a variable to the filter in order to pull the 12 rows of that date and paste it into a new sheet. Unfortunately, the value it pulls is not being passed, and when I put a MsgBox command in there, it shows it's pulling 12:00 AM and not a date. When using the Date variable, it also breaks the filter on the bottom macro below (trying 2 different versions just to get this working).
I'm not good with VBA, so my macros were pulled from example websites and I tailored them to what I need.
This is one macro I have tried:
Sub For_RangeCopy()
Dim rDate As Date
Dim rSheet As Worksheet
Set rSheet = ThisWorkbook.Worksheets("EOS")
rDate = CDate(rSheet.Range("B2").Value)
MsgBox (rDate)
' Get the worksheets
Dim shRead As Worksheet
Set shRead = ThisWorkbook.Worksheets("Bi-Hourly Report")
Dim shWrite As Worksheet
Set shWrite = ThisWorkbook.Worksheets("Report")
' Get the range
Dim rg As Range
Set rg = shRead.Range("A1").CurrentRegion
With shWrite
' Clear the data in output worksheet
.Cells.ClearContents
' Set the cell formats
'.Columns(1).NumberFormat = "dd/mm/yyyy"
'.Columns(3).NumberFormat = "$#,##0;[Red]$#,##0"
'.Columns(4).NumberFormat = "0"
'.Columns(5).NumberFormat = "$#,##0;[Red]$#,##0"
End With
' Read through the data
Dim i As Long, row As Long
row = 1
For i = 1 To rg.Rows.Count
If rg.Cells(i, 1).Value2 = rDate Or i = 1 Then
' Copy using Range.Copy
rg.Rows(i).Copy
shWrite.Range("A" & row).PasteSpecial xlPasteValues
' move to the next output row
row = row + 1
End If
Next i
End Sub
And here is another Macro I have tried to use. This one actually gives me the 3 header rows which I don't need, but I don't mind, this paste is a reference for the report layout anyway, so the operators won't see this sheet. But this macro does give me the first block of the date range: 1/1/2023. I do know that the "rgCriteria As String" is likely incorrect, but that is how I get anything useful from this macro. If I change that rgCriteria to a Date, it breaks the rgData.AdvancedFilter command, and I haven't learned enough VBA to know why. And my boss wants this done today, although here I am posting here, thus it's not getting done today.
Sub AdvancedFilterExample()
' Get the worksheets
Dim rSheet As Worksheet
Set rSheet = ThisWorkbook.Worksheets("EOS")
Dim shRead As Worksheet, shWrite As Worksheet
Set shRead = ThisWorkbook.Worksheets("Bi-Hourly Report")
Set shWrite = ThisWorkbook.Worksheets("Report")
' Clear any existing data
shWrite.Cells.Clear
' Remove the any existing filters
If shRead.FilterMode = True Then
shRead.ShowAllData
End If
' Get the source data range
Dim rgData As Range, rgCriteria As String
Set rgData = shRead.Range("A1").CurrentRegion
' IMPORTANT: Do not have any blank rows in the criteria range
'Set rgCriteria = rSheet.Range("B2")
rgCriteria = rSheet.Range("B2").Value
MsgBox (rgCriteria)
' Apply the filter
rgData.AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=rgCriteria _
, CopyToRange:=shWrite.Range("A1")
End Sub
I don't know which method of filtering and pasting is best for my situation, but I do know that the faster is better. I'm copying entire rows, and it needs to be efficient because this log contains a lot of data. I only need one of these macros to work, but I will be heavily modifying them and chaining them together with about 5 other filter/copy/paste sequences to follow, along with printOut commands after that, and finalized by clearing the sheets it pastes to, and then re-enabling all the functionality of the sheet (calculations, displaystatusbar, events, and screenupdating) all to make it quicker while the macro is running. All of these reports will be run using the macro with a button click.
Any thoughts or suggestions would be greatly appreciated. I've been struggling with this for a couple of weeks now. I'm at a loss and turning to the community that has helped me with a TON of questions over the past 20 or so years just by a Google search!
Other information:
I'm using Office 365 on a Windows 10/11 machine. The headers of the sheet it filters does contain merged cells as the header is rows 1-3, there is a lot of data in this sheet that grows through the year. 12 rows per day for an entire year. These macros are written in a Module aptly named "Module 1" if that helps. I do have this workbook, and the original log saved on OneDrive that can be shared.
When using Advanced Filter your criteria range should have headers which match your data table.
Sub AdvancedFilterExample()
Dim rSheet As Worksheet, shRead As Worksheet, shWrite As Worksheet
Dim rgData As Range, rgCriteria As Range
Set rSheet = ThisWorkbook.Worksheets("EOS")
Set shRead = ThisWorkbook.Worksheets("Bi-Hourly Report")
Set shWrite = ThisWorkbook.Worksheets("Report")
Set rgData = shRead.Range("A1").CurrentRegion 'source data range
'## criteria range needs to include a matching date header...
Set rgCriteria = rSheet.Range("B3:B4") 'eg. "Date" in B3, date value in B4
shWrite.Cells.Clear ' Clear any existing data
If shRead.FilterMode = True Then shRead.ShowAllData ' Remove the any existing filters
rgData.AdvancedFilter Action:=xlFilterCopy, _
CriteriaRange:=rgCriteria, _
CopyToRange:=shWrite.Range("A1")
End Sub
I have a template file, whereby multiple copies of the template (5 to 20) are completed, then consolidated into one master file. This file contains multiple sheets (18) and hundreds of entries in each sheet.
Not every cell is a number requiring consolidation, i.e there are titles and dates etc which are repeated, with no clear structure. Re-organising the template is not an option. The best way is to calculate only cells with a "Currency" type.
Here is the code I have so far. I have pieced it together from a number of searches, but will admit that I don't fully understand vba so I know I'm missing something obvious.
To make this a bit simpler, I have closed everything else and opened the target files manually before running this, then called upon the open excel files. Improving this bit of the code so that I can just put the target files into a sub folder and then use that path would be nice but not necessary.
I do not need to change the cell colour at the end, but I just did that as a quick visual reference to see whether it had ran.
The script in this format does not throw up any errors, but simply runs without actually calculating and populating the total value into each cell. I would guess that my approach of trying to extract the sheet and cell reference for every loop is wrong, but I cannot find the answer anywhere, so any help would be greatly appreciated.
totalValue = totalValue + Worksheets(sht).Cells(R, C)
is completely the wrong syntax, and the crux of the issue, but I simply don't know how to fix this within the context of the two existing For Each loops.
Sub ConsolidatedFigures()
Application.ScreenUpdating = False
'Declare variable types
Dim ws As Worksheet
Dim totalValue As Double
Dim C As Integer
Dim R As Integer
Dim wb As Workbook
Dim sht As String
Dim myRange As Range
Dim cell As Range
'Start to loop through each sheet in the workbook
For Each ws In ThisWorkbook.Worksheets
'get the current sheet name to later search for the same sheet in other workbooks
sht = ws.Name
'set the range in the current sheet
Set myRange = ws.UsedRange
'Now loop though every cell in the range
For Each cell In myRange
'Only target cells with an "currency" style so we're not trying to sum text
If cell.Style = "Currency" Then
'get the current cell references to later search for the same cell in other workbooks
C = cell.Column
R = cell.Row
'Within the current cell, go through open workbooks (except this one) to create a total of all the corresponding cells
For Each wb In Application.Workbooks
'the target workbooks will be open already, and nothing else. Disregard this open workbook and personal book
If wb.Name <> "PERSONAL.xlsb" AND wb.Name <> "consolidation.xlsm" Then
totalValue = totalValue + Worksheets(sht).Cells(R, C)
End If
Next wb
'populate the cell with the total of the corresponding cells
cell.Value = totalValue
'change cell colour to show the above step worked
cell.Interior.ColorIndex = 5
End If
'move on to next cell in worksheet
Next cell
'move on to next sheet in the workbook
Next ws
Application.ScreenUpdating = True
End Sub
The problem that I'm facing is concerning Excel. I'm trying to extract rows with multiple columns out of sheets based on certain criteria. I've found some solutions regarding this, but nothing is really what I'm looking for or I can't change it to make it work. I'll try to explain the issue more detailed below using an example.
Situation:
8 sheets (named Sh1 to Sh8) with a list of tasks
Each sheet represents a kind of task (personal, work, ...)
Each sheet has the same format
Data is located starting from row 4 and between column A to K
Below the data is a row with total calculations
The data includes text, numbers and blank cells
Column D is the status of the task (C for completed, I for in progress, N for not started)
Style of the sheets is completely done by using conditional formatting
I would like something that checks those 8 sheets and copies all entries (including the blank cells) that are a certain status, being either C, I or N, to a new sheet, called "Filtering". The filtering sheet will have headers as well and the data should start at row 7.
When I started this, I came up with a formula (based on this) that copies all the entries of one sheet. I could filter it by putting C, I or N in the cell D4 on the filtering sheet.
{
=IFERROR(
INDEX(
Sh1!A$4:A$19;SMALL(
IF(
Sh1!$D$4:$D19=Filtering!$D$4;
ROW(Sh1!A$4:A$19)-ROW(Sh1!A$4)+1
);
ROWS(Sh1!A$4:Sh1!A4)
)
);
"")
}
As I said before, the data includes blank cells, so I changed the formula to the following to make sure the blank cells didn't turn into 0's:
{
=IFERROR(
IF(
INDEX(SAME AS ABOVE)="";
"";
INDEX(SAME AS ABOVE);
);
"")
}
Although this worked, I could only perform this on one sheet, and not on all eight. I could solve this by starting Sh2 at a lower row in the filtering sheet and do this for all other sheets, but that's not really what I'd like to get. I would really like to get to a continuous list that sums up all the not started, completed or in progress by changing that one cell D4 on the filtering sheet.
That's where I would like your suggestions. If it's possible to do this without VBA, I'd prefer that, since I sometimes use it in the online web application and macro's don't work there. If VBA is the only solution, obviously that'd be okay too.
On a side note: I tried VBA based on a code that I found here. (please have patience with me, I never coded before this) but it seems really slow to process this. Every time I run the macro, it takes more than 15 seconds to calculate this, although there are only 200 tasks that I currently have. The following was for getting all the completed tasks. I could easily make the others by changing the C to I or N. There was another problem where the whole sheet was removed, including my headers, so I'd have to put a range on the clear.
Sub ExtractList()
Dim ws As Worksheet
Dim destinationWorksheet As Worksheet
Dim columnD As Range
Dim c As Range
Dim count As Long
Set destinationWorksheet = ActiveWorkbook.Worksheets("Filtering")
destinationWorksheet.Cells.ClearContents
count = 1
For Each ws In ActiveWorkbook.Worksheets
If ws.Name = "Sh1" Or ws.Name = "Sh2" Or ws.Name = "Sh3" Or ws.Name
= "Sh4" Or ws.Name = "Sh5" Or ws.Name = "Sh6" Or ws.Name = "Sh7" Or
ws.Name = "Sh8" Then
Set columnD = ws.Range("D:D") 'columnD
For Each c In columnD
If WorksheetFunction.IsText(c.Value) Then
If InStr(c.Value, "C") > 0 Then
c.EntireRow.Copy
destinationWorksheet.Cells(count, 1).PasteSpecial xlPasteValuesAndNumberFormats
count = count + 1
End If
End If
Next c
End If
Next ws
End Sub
Thanks already for reading through this and I'm looking forward to your suggestions.
Cheers,
Bart
The reason your code is taking too long to run is because you are looping through the entire column. You need to delimit the range to work with.
This solution:
• Allows the user to determine the extraction criteria using cell D4 in “Filtering” worksheet (Target)
• Sets the data ranges for each worksheet [Sh1, Sh2, Sh3, Sh4, Sh5, Sh6, Sh7, Sh8] (Source)
• Uses AutoFilter to select the data required and
• Posts the resulting ranges from all worksheets in the “Filtering” worksheet
It assumes that:
• All worksheets involved have the same structure and headers
• Headers are located at A6:K6 for Target worksheet and A3:K3 for Source worksheets (change as required)
Sub ExtractList()
Dim wshTrg As Worksheet, wshSrc As Worksheet
Dim sCriteria As String
Dim rDta As Range
Dim rTmp As Range, rArea As Range, lRow As Long
Rem Set Worksheet Target
Set wshTrg = ThisWorkbook.Worksheets("Filtering") 'change as required
Rem Clear prior data 'Header at row 6 & data starts at row 7 - change as required
With wshTrg
Rem Sets Criteria from Cell [D4] in target worksheet
sCriteria = .Cells(4, 4).Value2
.Cells(7, 1).Value = "X" 'To set range incase there is only headers
.Range(.Cells(7, 1), .UsedRange.SpecialCells(xlCellTypeLastCell)).ClearContents
End With
Rem Process each worksheet
lRow = 7
For Each wshSrc In ThisWorkbook.Worksheets
Select Case wshSrc.Name
Case "Sh1", "Sh2", "Sh3", "Sh4", "Sh5", "Sh6", "Sh7", "Sh8"
With wshSrc
Rem Clear AutoFilter
If Not (.AutoFilter Is Nothing) Then .Cells(1).AutoFilter
Rem Set Data Range
Set rDta = .Range(.Cells(3, 1), .Cells(.UsedRange.SpecialCells(xlCellTypeLastCell).Row, 11))
End With
With rDta
Rem Apply AutoFilter
.AutoFilter Field:=4, Criteria1:=sCriteria
Rem Set resulting range
Set rTmp = .Offset(1).Resize(-1 + .Rows.count).SpecialCells(xlCellTypeVisible)
Rem Clear Autofilter
.AutoFilter
End With
Rem Post Resulting range in target worksheet
For Each rArea In rTmp.Areas
With rArea
wshTrg.Cells(lRow, 1).Resize(.Rows.count, .Columns.count).Value = .Value2
lRow = lRow + .Rows.count
End With: Next: End Select: Next
End Sub
Suggest to read the following pages to gain a deeper understanding of the resources used:
Range Object (Excel), Range.Offset Property (Excel),
Range.SpecialCells Method (Excel),
Select Case Statement, Worksheet.AutoFilter Property (Excel),
Worksheet.AutoFilterMode Property (Excel), With Statement
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.
I'm tyring to look for a way to return a range of cells with just the lookup function. Is this really possible?
Basically like this:
=LOOKUP([MasterBook.xlsm]Sheet3!$A:$A,?)
I just want the function to look in the main workbook through all of Column A and return all cells for Column A that have something in them.
EDIT for poster below:
Sure. I have two workbooks; one workbook is essentially a local product that has a "master" sheet on top and then individual worksheets following it that have all of their information extracted from the master sheet. The second workbook is a local copy of a product that I send to a non-local entity higher up the food chain. Basically I need to pull information from the individual sheets in my first workbook and put it in the appropriate columns in the second workbook. I have a macro that gets the info from my sheets in the one workbook over to the other, but the second workbook is formatted differently. I was looking for a way to use a formula if possible.
The macro I am referring to is:
Sub CopyTest()
Dim sourceColumn As Range, targetColumn As Range
Set sourceColumn = Workbooks("Local Workbook.xlsm").Worksheets("Sheet3").Columns("A")
Set targetColumn = Workbooks("Nonlocal Workbook.xlsm").Worksheets("Sheet1").Columns("A")
sourceColumn.Copy Destination:=targetColumn
End Sub
All this does is pull the specified column from one sheet and put it in the column on the second book; but it just pastes it starting in the first block. Since the non-local book is formatted differently, the column I need to transfer to doesn't start until Row 9. shrug I have ideas abuot what I'm trying to do with this, but my ideas tend to exceed my technical ability (which occasionally makes it difficult to explain). :)
Depending on how different your workbooks are formatted. Here is two way to handle this:
Adapt your macro
Instead of copying the whole column, you can copy paste, only the values you want to.
Here is an example:
Sub CopyTest()
Dim rSource As Range, rTarget As Range
Dim lEnd As Long
lEnd = Range("A65536").End(xlUp).Row
Set rSource = Workbooks("Local Workbook.xlsm").Worksheets("Sheet3").Range("A1:A" & lEnd)
Set rTarget = Workbooks("Nonlocal Workbook.xlsm").Worksheets("Sheet1").Range("A9")
rSource.Copy Destination:=rTarget
End Sub
Use a formula
If your data are not in the same order, you'd better use a VLOOKUP formula.
See how it works.
Don't hesitate to post another question with what you've built for some help. Please give as much details as possible so we could help you the best way.
[EDIT] Another try following the comments
Option Explicit
Dim wTarget As Workbook
Sub mainCopy()
Dim bGo As Boolean
bGo = True
'Add a new workbook to copy the data - do you want the user to select one?
Set wTarget = Application.Workbooks.Add()
Do While bGo
CopyTest
bGo = MsgBox("Do you want to import data from another workbook?", vbYesNo, "Continue?")
Loop
End Sub
Sub CopyTest()
Dim rSource As Range, rTarget As Range
Dim lEnd As Long, lCol As Long
Dim ws As Worksheet
Dim vFile As Variant
vFile = Application.GetOpenFilename("Excel-files,*.xls", _
1, "Select One File To Open", , False)
'if the user didn't select a file, exit sub
If TypeName(vFile) = "Boolean" Then Exit Sub
Workbooks.Open vFile
For Each ws In ActiveWorkbook.Worksheets
'do you need to copy the columns separately?
' For lCol = 1 To 10
'find the last cell of the 10th column
lEnd = ws.Cells(65536, 10).End(xlUp).Row
Set rSource = ws.Range("A1:J" & lEnd)
'How can we define the target worksheet?
Set rTarget = wTarget.Worksheets("Sheet1").Range("A9")
rSource.Copy Destination:=rTarget
' Next lCol
Next ws
End Sub