I have to create new sheet using macros based by naming the first column value (Active cell) and need to give different header names and specific column values need to copy to the newly created sheet.
Note: A few column values need to copy from the source sheet to new sheet and need to give name for new sheet first column values of active cell. It should not apply for all column values, I mean name should be active cell value only.
As per the attached screen shots, I need to create value of project name column we need to create new sheet (second screen shot required output).
Something like this should be the goal:
Dim lrs as long, lrd as long, i as long
lrs = Sheets("Summary").cells(Sheets("Summary").Rows.Count,1).end(xlup).row
With Sheets("EMDN_SW_Project") 'longer to type than "Summary"
for i = 2 to lrs 'assumes header in row 1
'if statement if needed
lrd = .cells(.rows.count,1).end(xlup).row
.cells(lrd+1,1).value = Sheets("Summary").cells(i,1).value
'end if
next i
End With
I would recommend formatting at the end with the desired format, as opposed to assessing the formatting as you go (much slower).
Maybe somthing like that can help you. Creating a sheet for evey entries in a specific column of a Table.
Private Sub CreateSheets()
Dim ws As Worksheet
Dim RowCount As Integer
Dim TempName As String
Dim ImportTable As ListObject
Set ws = ThisWorkbook.Worksheets("WorkSheetName")
Set ImportTable = ws.ListObjects("TableName")
RowCount = ImportTable.ListRows.Count
'create a sheet for each value in a specific column of a table
For i = 1 To RowCount
TempName = ImportTable.DataBodyRange.Cells(i, ImportTable.ListColumns("ChoosedColumn").Index)
Sheets.Add.Name = TempName
Next
End Sub
Related
i have the following problem. I want to write a Macro, that copies three specific columns from a file "Rest.xlsx" into the original file "Schweben.xlsm". Both files are attached.
I already have the following code, which copies specific columns within the original file "Schweben.xlsm" from the table1 to a new created table2. Now i also want the macro to copy the columns K,H,D form Rest.xlsx to table2 within the "Schweben.xlsm" file into the new columns F,G,J (in that specific order). Since the files change daily, I want the macro to recognize the different lengths of the columns and always recognize all cells within the column, even if it is sometimes longer.
Sub CopyRowE()
Dim LastRowE As Long
Dim LastRowH As Long
Dim LastDataRow As Long
Dim CopyData As Long
With Tabelle1
LastRowE = .Range("E9999").End(xlUp).Row
LastRowH = .Range("H9999").End(xlUp).Row
.Range("E2:E" & LastRowE).Copy
.Range("CA1").PasteSpecial
.Range("H2:H" & LastRowH).Copy
.Range("CB1").PasteSpecial
LastDataRow = .Range("CB999999").End(xlUp).Row
.Range("CA1:CB" & LastDataRow).Copy
Sheets.Add
ActiveSheet.Range("A1").PasteSpecial
.Range("CA1:CB" & LastDataRow).ClearContents
Tabelle1.Select
.Range("A1").Select
End With
End Sub
Thanks in advance
Here is a simplified approach to copy columns of data from one sheet to another. I've matched what you asked for as best as I could understand your needs and commented the code well, so you can follow it. The important part here is the creation of a sub procedue that named "copy_column" that actually doest he copying when supplied with a source and destination cell.
Sub copyRowE()
Dim new_sheet As Worksheet
Dim source As Range
Dim dest As Range
Dim rest_sheet As Worksheet
'this code assumes that the Rest.xlsx workbook is open, if not, correct the
'following line and remove the comment character (')
'workbooks.open("c:\full\path\to\Rest.xlsx")
' copy E from tabelle1 to column A on new sheet
Set new_sheet = ThisWorkbook.Sheets.Add
'give new_sheet a name
'new_sheet.name = "Consolidated"
copy_column tabelle1.Range("E2"), new_sheet.Range("A1")
'copy H from tabelle1to column B on new sheet
copy_column tabelle1.Range("h2"), new_sheet.Range("B1")
'copy from the first sheet in rest.xlsx
Set rest_sheet = Workbooks("Rest.xlsx").Worksheets(1)
'OR copy from a particular sheet in Rest.xlsx
'Set rest_sheet = Workbooks("Rest.xlsx").Worksheets("Sheet1")
'copy column K from rest to column F on the new sheet
copy_column rest_sheet.Range("K2"), new_sheet.Range("F1")
'copy column H from rest to column G on the new sheet
copy_column rest_sheet.Range("H2"), new_sheet.Range("G1")
'copy column D from rest to column J on the new sheet
copy_column rest_sheet.Range("D2"), new_sheet.Range("J1")
End Sub
Sub copy_column(top_cell_in_source_column As Range, dest_cell As Range)
' copies data starting at top_cell_in_source_column and taking all data below it
' and pastes it beginning at dest_cell. The source and destination can be in
' different worksheets or even in different workbooks
Dim source_sheet As Worksheet
Dim source_col As Long
Set source_sheet = top_cell_in_source_column.Parent
source_col = top_cell_in_source_column.Column
Range(top_cell_in_source_column, source_sheet.Cells(source_sheet.Rows.Count, source_col).End(xlUp)).Copy dest_cell
End Sub
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.
So in the simplest explanation; I want to search through my ListObjecttable of data (specifically column 9) and copy values to another sheet if they match a criteria (ignore this bit for now).
Currently my code sets out the table as a list object but doesn't specify the column due to the fact I'll be using multiple columns.
When I go to loop through the ninth column though it provides me a runtime error 9. Am I referring to the column incorrectly?
Sub RequestedAssetList()
Dim FullAssLi As ListObject, RowToPasteTo As Long 'Defining the Table and Range
Set FullAssLi = ThisWorkbook.Sheets("Asset List").ListObjects("AssListTab") 'Set FullAsset Lists as the Asset Table
With ThisWorkbook 'Within the workbook
.Sheets.Add(After:=.Sheets(.Sheets.Count)).Name = "Assets" 'Adds a sheet at the end of the workbook called Assets
End With
With ThisWorkbook.Sheets("Assets")
RowToPasteTo = .Cells(.Rows.Count, "A").End(xlUp).Row + 1 'Sets variable as the next exmpy row on column A of Assets' tab
For i = 1 To ThisWorkbook.Sheets("Asset List").ListObjects("AssListTab").Range.Rows.Count 'For first interger to last row in table
If FullAssLi.ListColumns(9).Value = UserForm2.SourceLiBo.Value Then
End If
Next i
End With
End Sub
Is the line If FullAssLi.ListColumns(9).Value = UserForm2.SourceLiBo.Value Then incorrect?
EDIT: The userform is bringing through a value set in the code run before.
You are refering to the full column all the time:
If FullAssLi.ListColumns(9).Value = UserForm2.SourceLiBo.Value Then
Instead try something like:
Dim LRow as ListRow
For Each LRow In FullAssLi.ListRows
If LRow.Range.Cells(9).Value = UserForm2.SourceLiBo.Value Then
End If
Next
In a previous question a solution was offered to create a dynamic subset of a master list, on a separate worksheet. I need to do something very similar, but cannot seem to adequately adapt the solution to the other question, to my specific need.
My situation is that I have 35 accounts to reconcile. Each account has a unique five digit number. The master data list has 6 columns. I want a sheet for each of the 35 accounts, and each sheet will pull only the rows where the third column matches the specific worksheet's account.
To expound further. Let's take only three of the thirty five. We will use 40000, 40100, and 40200. The six columns are "Entry ID", "Date", "Account Number", "Debit", "Credit", and "Reference".
On worksheet 1, "40000", I want to pull the six columns of data, only for the rows where the "Account Number" = the name of my worksheet (40000). On the second worksheet, called "40100", I only want to pull the six columns of data for the rows that contain "40100" in the "Account Number" column, and on the third worksheet, called "40200", I want to pull the six columns of data that contain "40200" in the "Account Number" column.
The previous answer provided a way to create a subset on a separate worksheet, but with the key value on the same sheet as the master data list. I want the key value to be listed on each worksheet, so that I don't have to a complete data list for each account.
edit:
This is the initial question/answer I referred to in my question above. I liked the bottom solution that used "rank," but like I said above, I would love it if the key value could be on each worksheet, i.e. 40000, 40100, 40200, etc..., not on the master data list. The key value would be the worksheet name, i.e. the account number (40000, 40100, etc...)
The sheets already exist. Each month I simply open the previous month's sheet, save it as my new month, and overwrite the data with the new month's data.
Any assistance would be GREATLY appreciated.
Thank you!
This is easily accomplished through a few nested loops.
The key elements are: Getting the last Row of each sheet involved, and looping through the rows, sheets, and columns, using IF statements to conditionally test whether the account number matches the sheet name.
Let's look at it from beginning to end. Follow with the comments:
1. Loop through Source Sheet, every row
2. Loop through each Worksheet to find match of tempAccount value to sheet name
3. Once match is found, loop through all 6 columns copying from one sheet to the next.
TESTED:
Private Sub AccountsToSheets()
Dim lastRow As Long 'Last Row on source sheet
Dim lastTRow As String 'For last Target Row
Dim target As String 'For temp name
Dim tRow As Long 'Target Row
Dim source As String 'Source Sheet Name
Dim tempAccount As String 'Variable for account number
Dim ws As Worksheet 'For looping through worksheets
'----SETUP VARIABLES----;
source = "Sheet1" 'Define Name of Source Sheet HERE
lastRow = Sheets(source).Range("A" & Rows.count).End(xlUp).row
'----BEGIN LOOP THROUGH SOURCE SHEET----'
For lRow = 2 To lastRow
tempAccount = Sheets(source).Cells(lRow, "C").Text
'--BEGIN LOOP THROUGH WORKSHEETS TO CHECK FOR MATCH--'
For Each ws In Worksheets
If ws.Name <> source Then 'Eliminate checking Source Sheet
If ws.Name = tempAccount Then 'Use sheet that's name matches tempAccount
target = ws.Name
lastTRow = Sheets(target).Range("A" & Rows.count).End(xlUp).row
tRow = lastTRow + 1 'Set the row value on target sheet
'--LOOP THROUGH ALL COLUMNS AND COPY DATA--'
For lCol = 1 To 6
Sheets(target).Cells(tRow, lCol) = Sheets(source).Cells(lRow, lCol)
Next lCol
End If
End If
Next ws
Next lRow
End Sub
I have a workbook filled with text-based data on several different sheets. All the sheets use the same headings, but have different text in the columns. I would like to be able to list the information contained in the column C from all of the sheets in a single column in a new sheet.
Is there a way to get all of that data into a single column without having to copy and past from nearly 100 different sheets?
Using VBA, here is a solution that works. You just need to insert a module into your workbook and run this. F11 > Insert > Module. Copy and paste this code, and hit play.
This will create a new worksheet with whatever name you define under newSheet. Then take the contents of EVERY worksheet Row C (after header), no matter how many you have or what their name is, and add them to the new one. I could see a problem if you exceed 1,000,000 rows.. Other than that, if there are any sheets you DON'T want to perform this on, we would add them as exceptions specifically by name in the If statement.
TESTED:
Private Sub CopyAllSheetsCol()
Dim WS As Worksheet
Dim newSheet As String
Dim lastRow As Long 'Last Row on source Sheet
Dim tRow As Long 'target row
newSheet = "Compiled" 'name can be changed here
Sheets.Add.Name = newSheet
tRow = 2 'Set the target Row to 2, Set the Header Row manually
For Each WS In ActiveWorkbook.Worksheets
If WS.Name <> newSheet Then 'Making sure we are only working with pre-existing sheets
lastRow = Sheets(WS.Name).Range("C2").End(xlDown).Row 'get last row of Column C on each Worksheet
For r = 2 To lastRow 'Loop through all rows skipping header
Sheets(newSheet).Cells(tRow, "C") = Sheets(WS.Name).Cells(r, "C") 'Copy to newSheet
tRow = tRow + 1 'Increment target row by 1
Next r
End If
Next
End Sub
edit: touched up explanation