I'm a little stuck at the moment on the problem - I have a workaround but it's very inefficient and also very time consuming to code.
I have a selection of worksheets and I would like to add a different header row to each of these sheets based on the sheet name.
I would like to have a worksheet containing a selection of header rows - see Selection of Header Rows
Then, for example, if the worksheets = A00 - apply the copy in the corresponding Header Row from the Selection worksheet.
This is my current solution - as you can see it is very inefficient and time-consuming
For Each myWorksheet In Worksheets
If myWorksheet.Name = "A00" Then
Sheets("A00").Cells(1).Resize(1, 5).Value = Array("ORGANISATION_ID", "FILE_TYPE", "CREATION_DATE", "CREATION_TIME", "GENERATION_NUMBER")
End If
If myWorksheet.Name = "Z99" Then
Sheets("Z99").Cells(1).Resize(1, 1).Value = Array("RECORD_COUNT")
End If
If myWorksheet.Name = "I56" Then
Sheets("I56").Cells(1).Resize(1, 26).Value = Array("ORGANISATION_SHORT_CODE", "INVOICE_NUMBER", "INVOICE_TYPE_CODE", "BILLING_YEAR", "BILLING_MONTH", "INVOICE_AMOUNT", "INVOICE_VAT_AMOUNT", "INVOICE_GROSS_TOTAL", "PAYMENT_DUE_DATE", "VAT_CHARGED_TO_NWO", "VAT_CHARGED_TO_SHIPPER", "INVOICE_TAX_POINT_DATE", "NWO_VAT_ REGISTRATION_NUMBER", "NWO_BANK_SORT_CODE", "NWO_BANK_ACCOUNT_NUMBER", "NWO_BANK_ACCOUNT_NAME", "ISH_VAT_REGISTRATION_NUMBER", "ISH_BANK_ACCOUNT_NUMBER", "ISH_BANK_SORT_CODE", "NWO_SHORT_CODE", "NWO_VAT_REGISTRATION_NAME", "NWO_ADDRESS_LINE_1", "NWO_ADDRESS_LINE_2", "NWO_ADDRESS_LINE_3", "NWO_ADDRESS_LINE_4", "FILE_NAME")
End If
If myWorksheet.Name = "I05" Then
Sheets("I05").Cells(1).Resize(1, 2).Value = Array("ISC_LINE_1_TEXT", "ISC_LINE_2_TEXT")
End If
If myWorksheet.Name = "I57" Then
Sheets("I57").Cells(1).Resize(1, 8).Value = Array("INVOICE_ITEM_REFERENCE_NUMBER", "INCURRED_DATE", "CHARGE TYPE CODE", "QUANTITY", "UNIT_TYPE", "RATE", "INVOICE_ITEM_AMOUNT", "ANCILLARY_INVOICE_COMMENTS")
End If
If myWorksheet.Name = "K12" Then
Sheets("K12").Cells(1).Resize(1, 4).Value = Array("GAS_ACT_OWNER", "CURRENT_METER_ASSET_MANAGER", "PROSPECTIVE_METER_ASSET_MANAGER", "PROSPECTIVE_MAM_EFFECTIVE_DATE")
End If
Next myWorksheet
Any help with this would be much appreciated.
Create a worksheet called Index and populate it as you have done in the image.
Then, the following code will work through each tab and if the tab name is found in column A it will copy the entire row below that cell into the first row of the tab.
For Each myworksheet In Worksheets
rowfound = Application.Match(myworksheet.Name, Worksheets("Index").Range("A:A"), 0)
If Not (IsError(rowfound)) Then myworksheet.Range("1:1").Value = Worksheets("index").Cells(rowfound + 1, 1).EntireRow.Value
Next
I think I would approach this by doing the steps listed below, with the following assumptions about your worksheets.
The worksheet in your image is named "Selection of Header Rows".
The worksheet in your image will have empty rows between the header
listings as pictured.
The first column pictured in your image is
Column A.
You want the headers to start in Cell A1 of the individual
sheets.
Steps
Define a range of the pictured worksheet in which we'll search for each worksheet's name.
Loop through each worksheet in the collection, finding its name in our search range.
If the name is found, define a range by using the CurrentRegion property of the range in which the name was found. (The current region is a range bounded by any combination of blank rows and blank columns.)
Count the columns in that range.
Offset that range down one row (to exclude the sheet name itself).
Resize that range to be one row "high" and the same number of columns "wide".
Set the header range on the target sheet to be the cell A1 and resize it to have the correct number of columns.
Set the value of that header range equal to the value of the range we built on the "Selection of Header Rows" worksheet.
Dim myWorksheet As Worksheet
Dim searchRange As Range
Set searchRange = Worksheets("Selection of Header Rows").Range("A:A")
Dim foundRange As Range
Dim headerRange As Range
For Each myWorksheet In Worksheets
Set foundRange = searchRange.Find(What:=myWorksheet.Name, LookAt:=xlWhole)
If Not foundRange Is Nothing Then
Set headerRange = foundRange.CurrentRegion.Offset(1, 0)
Dim headerColumnCount As Long
headerColumnCount = headerRange.Columns.Count
Set headerRange = headerRange.Resize(1, headerColumnCount)
myWorksheet.Range("A1").Resize(1, headerColumnCount).value = headerRange.value
End If
Next myWorksheet
Related
I'm trying to create a VBA script that goes into file1 and copies the data into file2. File 1 contains the data.
The issue I'm having is file2 has more columns and not necessarily in the same order as the ones in file1. As well, the Range is wrong, I'm not sure how to select all relevant data. How do i make sure it gets all the relevant rows per column in file1?
Sub GetDatacClosedBook()
Dim src As Workbook
Set src = Workbooks.Open("C:\Users\Data\Documents\File1", True, True)
Set wbOpen = ActiveWorkbook
'this is the workbook in which the data will be transferred to
Workbooks.Open "C:\Users\Data\Documents\file2.xlsx"
Worksheets("Sheet1").Range("A1:D3").Formula = src.Worksheets("Sheet1").Range("A1:D3").Formula
wbOpen.Close
End Sub
You should first figure out the columns in your data sheet match which columns in your destination sheet. And then everything should be easy. This can be done in multiple way. I assume your A row has the headers, then you can match the column by match the headers
Sub Macro()
Dim destSht As Worksheet, srcSht As Worksheet
Dim src_ColCnt As Integer, dest_ColCnt As Integer
'Open the workbooks and grab the sheet reference, assign it to a worksheet variables
Set srcSht = Workbooks.Open("D:\data.xlsx").Sheets("Sheet1")
Set destSht = Workbooks.Open("D:\report.xlsx").Sheets("Sheet1")
'Find how many columns in your destination sheet, how many columns in your source sheet and how many rows the source sheet data has.
dest_ColCnt = destSht.Range("A1").End(xlToRight).Column
src_ColCnt = srcSht.Range("A1").End(xlToRight).Column
src_RCnt = srcSht.Range("A1").End(xlDown).Row - 1
'The code below is basically loop over the source sheet headers, and for each header
'find the column in your destination that has the same header
'And then assign the data row by row once it knows which column in the data sheet go to which column in the destination sheet
For i = 1 To src_ColCnt
Header = srcSht.Cells(1, i)
For j = 1 To dest_ColCnt
If destSht.Cells(1, j).Value = Header Then
For r = 1 To src_RCnt
'Do your assignment here row by row
'You can assign formula, value or different thing based on your requirement
'I assume your data start from the second row here
destSht.Cells(r + 1, j).Value = srcSht.Cells(r + 1, i).Value
Next r
End If
Next j
Next i
End Sub
This is not elegant but should give you the idea. To make the above more elegant, There are a couple of things you can use. One, using Scripting.Dictionary data structure to hold the headers in the dictionary as key, the column ordinal as the value. And then you loop your destination sheet column by column. Retrieve the right column ordinal from the dictionary. Two, you can use WorksheetFunctions.Match() to find the ordinal. Or even better if you know the order by yourself. You can just hard coding an order Array, like mapOrder = Array(3,1,5,6) and just use this array to match the column.
You could write a function that points to a specific workbook, locates a column -perhaps by heading- and captures that columns data into an Array which is returned by the function.
Then write the arrays in the desired order to the other sheet.
Example for the Subroutine and the function:
Private Sub GetDatacClosedBook()
Dim ExampleArray As Variant
Dim Destination As Range
ExampleArray = LocateColumnReturnArray(ThisWorkbook.Sheets("Sheet1"), "Value to find in row1 of the desired column")
Set Destination = ThisWorkbook.Sheets("Sheet2").Range("A1")
Destination.Resize(UBound(ExampleArray), 1) = ExampleArray
End Sub
Public Function LocateColumnReturnArray(ByRef TargetWorksheet As Worksheet, ByVal TargetColumnHeader As String) As Variant
Dim LastUsedColumn As Long
Dim TargetCell As Range
With TargetWorksheet
LastUsedColumn = .Cells(1, .Columns.Count).End(xlToLeft).Column
For Each TargetCell In .Range(.Cells(1, 1), .Cells(1, LastUsedColumn))
If TargetCell.Value = TargetColumnHeader Then
LastUsedRow = .Cells(.Rows.Count, LastUsedColumn).End(xlUp).Row
LocateColumnReturnArray = .Range(.Cells(2, TargetCell.Column), .Cells(LastUsedRow, TargetCell.Column))
Exit Function
End If
Next TargetCell
End With
End Function
You can take this concept and apply it to your requirements.
This function could be run as many times as required for each column you want the data for.
You would need to also specify the target for each column of data but you could modify the above to use a loop based on the columns your data is being written to.
I have been looking around the site for a while for an answer to this question but no luck just yet. I have this code where I loop through a row of numbers and depending on what number is in the cell at the time, determines what I copy and paste to the sheet. I am using Columns for this because it is the only way I can make my code dynamic. It works but when I paste I would like to paste in cells lower than where it's pasting right now. I was wondering if Columns had a way of specifying what column and where to paste my data.
Code:
Dim sh As Worksheet
Dim rw As Range
Dim row As Range
Dim cell As Range
Dim RowCount As Integer
Set rw = Range("A5:CG5")
Set sh = ActiveSheet
For Each row In rw.Rows
For Each cell In row.Cells
Select Case cell.Value
Case "2"
ThisWorkbook.Worksheets("Sheet1").Range("E27:E51").Copy Destination:=Sheets("Sheet2").Columns(4)
End Select
Next cell
Next row
Your problem can be solved as Jeeped said, use Destination:=Sheets("Sheet2").Cells(27, 5) or Destination:=Worksheets(2).Range("E27")
Since you want to learn a little bit more, i made an example explanation:
https://msdn.microsoft.com/en-us/vba/excel-vba/articles/range-column-property-excel
On the link it is explained that .Column:
Column A returns 1, column B returns 2, and so on.
And the same is with the .Rows
Use .Cells https://msdn.microsoft.com/pt-br/library/office/ff194567.aspx So you can use the .Cells(Rows,Columns) or .Cells(Index from a Range) or the entire Object:
With Worksheets("Sheet1").Cells.Font
.Name = "Arial"
.Size = 8
End With
So an example if you want to turn your spreadsheet dynamical: to copy from range $E$27 to last row with something written from column $E on Sheet1 To
the last column with nothing written on row 1 on Sheet2.
Sub test()
'Declare variables here
Dim sht1, sht2 As Worksheet
'sht1 has the data and sht2 is the output Worksheet, you can change the names
last_row = Worksheets(1).Range("E65536").End(xlUp).Row
last_column = Worksheets(2).Cells(1, sht1.Columns.Count).End(xlToLeft).Column
'Data add
For i = 27 To last_row
'Start from Row 27
Worksheets(2).Cells(i - 26, last_column + 1) = Worksheets(1).Cells(i, 5)
Next i
MsgBox "Data Updated"
End Sub
And an example of a basic dynamical workbook with i=i+1 and For loops split a single row of data into multiple unique rows into a new sheet to include headers as values and cell contents as values
I have a range of cell numbers that I need for multiple worksheet names.
I create multiple worksheets based on the number of rows.
Sub Copier()
Dim x As Integer
x = InputBox("Enter number of times to copy worksheet")
For numtimes = 1 To x
ActiveWorkbook.Sheets("OMRS 207").Copy _
After:=ActiveWorkbook.Sheets("OMRS 207")
Next
End Sub
That grabs only one name, OMRS 207.
I want to generate these worksheets using the entire range of cells in the original worksheet.
Try below code.
Dim data As Worksheet
Dim rng As Range
Set data = ThisWorkbook.Sheets("Sheet1")
Set rng = data.Range("A2")
Do While rng <> ""
ThisWorkbook.Worksheets.Add
ActiveSheet.Name = rng.Value
Set rng = rng.Offset(1, 0)
Loop
I assumed that your data starts from 2nd row in Sheet1 and you want the sheet name as per values in Column A.
If you want row number as sheet name for newly added sheet just use rng.row while assigning name to sheet.
Using For Each and the Find method, I can look for a cell in a range even if the range is multiple columns by multiple rows. But how can I look for a set of cells in a range?
For example, I have a reference book whose row entries fill rows 2-7 and are two columns wide. I need to find if they have an exact match to the row entries (which also begin in row 2 and are two columns wide) in my target book. If it finds a match, it pastes the row # from the reference file into column 5. Otherwise, it pastes in the new entry. Here's the code so far:
Dim NewFile as Workbook 'defined as the location of the reference book
Dim NewSht as Worksheet 'defined as the sheet in NewFile
Dim ThisSht as Worksheet 'defined as the sheet in the target book
Dim NewName as Range
Dim LastEntry as Range
Dim OldNameRange as Range
Dim EntryMatch as Range
For Each NewName In NewSht.Range(NewSht.Cells(2, 1), NewSht.Cells(Rows.Count, 2).End(xlUp)) 'loops thru each set of entry labels in new sheet
Set LastEntry = ThisSht.Cells(Rows.Count, 2).End(xlUp)
Set OldNameRange = ThisSht.Range(ThisSht.Cells(2, 1), LastEntry)
Set EntryMatch = OldNameRange.Find(NewName.Value, LookIn:=xlValues, lookat:=xlWhole, MatchCase:=True)
If Not EntryMatch Is Nothing Then
ThisSht.Cells(EntryMatch.Row, 5).Value = NewName.Row
Else
ThisSht.Cells(LastEntry.Row + 1, 1).Resize(1, 2).Value = NewSht.Range(NewSht.Cells(NewName.Row, 1), NewName.Cells(NewName.Row, 2)).Value
ThisSht.Cells(LastEntry.Row + 1, 3).Value = NewName.Row
End If
Next
Right now, it's only comparing cell by cell. Can anyone help me get it to compare a set of cells (each row of entries) against each set of cells in the OldNameRange? Thanks!
I am fairly new to Excel VBA and have been trying to look for (as well as come up with my own) solutions to a dilemma I am facing. Routinely, I receive raw data files from a colleague and these raw data files may have varying number of columns but consistent header names. I have in my workbook, a master spreadsheet that I want to keep up to date by appending the new data (so keep appending data of new spreadsheet to next empty row). I would like to create a macro that can take the imported spreadsheet (say, spreadsheet A) and look at the header value of a column, copy the column range (starting from row 2 to end of populated within column), go to spreadsheet Master, look for header value, and paste the column range in the next empty cell down in the column. And this procedure would be for all columns present in spreadsheet A.
Any help/guidance/advice would be very much appreciated.
Ex) I have "master" sheet and "imported" sheet. I want to take the "imported" sheet, look at headers in row 1, starting from column 1. If that header is present in "master" sheet, copy the column (minus the header) from "imported sheet" and paste into "master" under the appropriate column header starting from the next empty cell in that column. What I ultimately want to do is keep the "master" sheet with historical data but the "imported" sheet contains columns which moves around so I just couldn't copy and paste the range starting from next empty cell in master.
Untested but compiles OK:
Sub CopyByHeader()
Dim shtA As Worksheet, shtB As Worksheet
Dim c As Range, f As Range
Dim rngCopy As Range, rngCopyTo
Set shtA = ActiveSheet ' "incoming data" - could be different workbook
Set shtB = ThisWorkbook.Sheets("Master")
For Each c In Application.Intersect(shtA.UsedRange, shtA.Rows(1))
'only copy if >1 value in this column (ie. not just the header)
If Len(c.Value) > 0 And Application.CountA(c.EntireColumn) > 1 Then
Set f = shtB.Rows(1).Find(what:=c.Value, LookIn:=xlValues, _
LookAt:=xlWhole)
If Not f Is Nothing Then
Set rngCopy = shtA.Range(c.Offset(1, 0), _
shtA.Cells(Rows.Count, c.Column).End(xlUp))
Set rngCopyTo = shtB.Cells(Rows.Count, _
f.Column).End(xlUp).Offset(1, 0)
'copy values
rngCopyTo.Resize(rngCopy.Rows.Count, 1).Value = rngCopy.Value
End If
End If
Next c
End Sub
EDIT: updated to only copy columns which have any content, and to only copy values
I cannot get the above to work, and need the same result as the original question. Any thoughts on what is missing? I thought I changed everything that needed to be changed to fit my sheets:
Sub CopyByHeader()
Dim shtMain As Worksheet, shtImport As Worksheet
Dim c As Range, f As Range
Dim rngCopy As Range, rngCopyTo
Set shtImport = ActiveSheet
' "Import"
Set shtMain = ThisWorkbook.Sheets("Main")
For Each c In Application.Intersect(shtImport.UsedRange, shtImport.Rows(1))
'only copy if >1 value in this column (ie. not just the header)
If Len(c.Value) > 0 And Application.CountA(c.EntireColumn) > 1 Then
Set f = shtMain.Rows(1).Find(what:=c.Value, LookIn:=xlValues, _
LookAt:=xlWhole)
If Not f Is Nothing Then
Set rngCopy = shtImport.Range(c.Offset(1, 0), _
shtImport.Cells(Rows.Count, c.Column).End(xlUp))
Set rngCopyTo = shtMain.Cells(Rows.Count, _
f.Column).End(xlUp).Offset(1, 0)
'copy values
rngCopyTo.Resize(rngCopy.Rows.Count, 1).Value = rngCopy.Value
End If
End If
Next c
End Sub
Thanks,
Ryan