I have a sheet that contains a week number in column B. I am trying to create a macro which looks for the week number in Cell J2 (or using an inputbox) and then finds the week number in column B selects the data in columns C-G and copies them over to sheet 2 (I can do the copying etc its defining the range i'm struggling with.) Image of datasheet
Here is the code which shows which info I need to copy and paste. I'm struggling to make it find the week number and then define the range. The code below just does week 4.
Sub Copy4()
'
' Copy Macro
' Week number
Sheets("Sheet1").Range("B14:B17").Copy
Sheets("Sheet2").Range("C3").PasteSpecial Paste:=xlPasteValues
Sheets("Sheet2").Range("D3").PasteSpecial Paste:=xlPasteValues
' Data Copy
Sheets("Sheet1").Range("C14:G17").Copy
Sheets("Sheet2").Range("C4").PasteSpecial Paste:=xlPasteValues
Range("B2:G7").Select
Application.CutCopyMode = False
Selection.CopyPicture Appearance:=xlScreen, Format:=xlBitmap
End Sub
Thanks in advance for any help
Sub copy()
Dim CopySheet As Worksheet
Dim PasteSheet As Worksheet
Set CopySheet = Worksheets("Sheet2")
Set PasteSheet = Worksheets("Sheet3")
Dim tableMaxCol As Integer
Dim tableMaxRow As Integer
Dim weekNumber As Integer
Dim row As Integer
tableMaxCol = CopySheet.Cells(1, CopySheet.Columns.Count).End(xlToLeft).Column
tableMaxRow = CopySheet.Cells(CopySheet.Rows.Count, 1).End(xlUp).row
weekNumber = CopySheet.Cells(2, 10).Value
For row = 2 To tableMaxRow step 4
If CopySheet.Cells(row, 2).Value = weekNumber Then
CopySheet.Range(CopySheet.Cells(row, 3), CopySheet.Cells(row + 3, 7)).copy _
Destination:=PasteSheet.Range("C4")
End If
Next row
End Sub
Answer edited.
Related
I have a excel which has multiple rows and columns and range of column values differ for each row.
Need a macro which will delete all cells in a row except first and last in each row and paste the last value next to first value.
Tried the below script:
Sub test()
Dim sh As Worksheet
Dim IDS As range
Dim ID As range
Set sh = ThisWorkbook.Sheets("Sheet1")
Set IDS = ActiveSheet.range("A2", range("A1").End(xlDown))
For Each ID In IDS
Dim b As Integer
Dim k As Integer
k = sh.range("ID", sh.range("ID").End(xlToRight)).Columns.Count
b = k - 1
range(ID.Offset(0, 0), ID.Offset(0, "b")).Select
Selection.ClearContents
Next ID
End Sub
This is a little different approach but should help.
Also, it is generally not best to declare variables in a loop as you do with b & k just fyi
Sub test()
Dim sh As Worksheet
Dim row As Integer
Dim lastCol As Integer
Set sh = ThisWorkbook.Sheets("Sheet1")
For row = 2 To sh.Cells(Sheets(1).Rows.Count, "A").End(xlUp).row
lastCol = sh.Cells(row, Columns.Count).End(xlToLeft).Column
sh.Range("B" & row).Value = sh.Cells(row, lastCol).Value
sh.Range(sh.Cells(row, 3), sh.Cells(row, lastCol)).ClearContents
Next
End Sub
Best of luck
I'd go as follows:
Sub test()
Dim cell As Range
With ThisWorkbook.Sheets("Sheet1") ' reference relevant sheet
For Each cell In .Range("A2", .Cells(.Rows.Count, "A").End(xlUp)) ' loop through referenced sheet column A cells from row 2 down to last not empty one
With .Range(cell, .Cells(cell.Row, .Columns.Count).End(xlToLeft)) ' reference referenced sheet range spanning from current cell to last not empty one in the same row
If .Count > 2 Then ' if referenced range has more then 2 cells
cell.Offset(, 1).Value = .Cells(1, .Count).Value ' store last cell value next to the current one
.Offset(, 2).Resize(, .Columns.Count - 1).ClearContents 'clear all cells right of current one
End If
End With
Next
End With
End Sub
You can use Range.Delete Method (Excel)
range(ID.Offset(0, 0), ID.Offset(0, b)).Delete Shift:=xlToLeft
I am new to VBA as a language, and I'm having issues sorting a large spreadsheet. The sheet is roughly 400,000 rows by 8 columns. The relevant data begins on row 5. In Column C, I changed the format of the date and rounded it down to give a single integer representing the day.
The goal is to find where the data changes days, and cut and paste all of that day's data to a seperate tab. The code I have written successfully does this for the first 2 days, but the 3rd iteration and beyond will not work properly. I have used a color code (blue) to represent the last row for each day, and I'm using this color change as my loop condition. The 3rd loop ignores the 1st color change and instead cuts and pastes 2 day's worth of data, and the 4th loop moves 3 days.
Would there be a more efficient way to move each day's data to a new tab? Each day represents 28800 rows by 6 columns. It should be noted that an additional macro is run before this in order to simply organize the raw data. The portion of the code giving me issues are the loops following the "Sort the data by date" comment.
Any help would be greatly appreciated! Thanks in advance. Attached is my code and a sample of the data
Sub HOBO_Split_v2()
'Before this code can be run, you must run "Hobo_Organize" 1 time. Press 'Ctrl + Shift + O' to do this
'The purpose of this code is to separate the hobo data by day. Weekends and evenings will be removed.
'This will create smaller data sets, which allows for easier data manipulation
Application.ScreenUpdating = False
'Find the last row
Lastrow = Range("C" & Rows.Count).End(xlUp).Row
'Set the known parameters
Dim days As Range
Set days = Worksheets("Full Data Set").Range("C5:C" & Lastrow)
Dim daychanges As String
daychanges = 0
'Maximum of 3 weeks of data, 21 different sheets
Dim sheetnum(1 To 21) As Integer
For i = 1 To 21
sheetnum(i) = i
Next i
'Loop through the day index (Col C), counting the number of day changes
For Each cell In days
If cell.Value <> cell.Offset(1).Value Then
cell.Interior.ColorIndex = 37
daychanges = daychanges + 1
End If
Next cell
'Add new sheets for each day and rename the sheets
Sheets.Add after:=ActiveSheet
ActiveSheet.Name = "Day 1"
For i = 2 To daychanges
Sheets.Add Before:=ActiveSheet
ActiveSheet.Name = "Day " & sheetnum(i)
Next i
Sheets("Full Data Set").Select
'Sort the data by date
For Each cell In days
If cell.Interior.ColorIndex = 37 Then
cell.Select
Range(Selection, Selection.End(xlUp)).Select
Range(Selection, Selection.End(xlToRight)).Select
Selection.Cut
Worksheets(Worksheets.Count).Select
ActiveSheet.Range("B2").Select
ActiveSheet.Paste
Application.CutCopyMode = False
ActiveSheet.Move Before:=Sheets("Full Data Set")
Sheets("Full Data Set").Select
Range("C4").Select
Selection.End(xlDown).Select
Range(Selection, Selection.End(xlDown)).Select
Set days = Selection
End If
Next cell
Application.ScreenUpdating = True
End Sub
Example of the data
I'd not pass through any cell coloring and use RemoveDuplicates() method of Range object as like follows:
Option Explicit
Sub HOBO_Split_v2()
Dim datesRng As Range, dataRng As Range, cell As Range
Dim iDay As Long
Application.ScreenUpdating = False
With ThisWorkbook.Worksheets("Full Data Set")
Set datesRng = .Range("C5", .Cells(.Rows.Count, 3).End(xlUp)) '<--| set dates range
Set dataRng = datesRng.offset(-1).Resize(datesRng.Rows.Count + 1, 6) '<--| set data range as dates one extended to next 5 columns
With datesRng.offset(, .UsedRange.Columns.Count) '<--| use a helper column out of current used range
.value = datesRng.value '<--| copy dates value in helper column
.RemoveDuplicates Columns:=Array(1) '<--| remove duplicates and have only unique values in helper column
For Each cell In .Cells.SpecialCells(xlCellTypeConstants, xlNumbers) '<--| iterate through remaining (unique) day values in helper column
iDay = iDay + 1 '<--| update "current day" counter
dataRng.AutoFilter Field:=1, Criteria1:=Format(cell, "#.00") '<--| filter data by "current day", format the criteria as the actual column C cells format
dataRng.offset(1).Resize(dataRng.Rows.Count - 1).SpecialCells(xlCellTypeVisible).Copy Destination:=SetWorkSheet(ThisWorkbook, "Day " & iDay).Range("B2") '<--| copy filtered data and paste the into "current day" corresponding sheet
Next cell
.Parent.AutoFilterMode = False '<--| remove autofilter
.Clear '<--| clear helper column
End With
End With
Application.ScreenUpdating = True
End Sub
Function SetWorkSheet(wb As Workbook, SheetName As String) As Worksheet
On Error Resume Next
Set SetWorkSheet = wb.Worksheets(SheetName)
On Error GoTo 0
If SetWorkSheet Is Nothing Then
Set SetWorkSheet = wb.Worksheets.Add(after:=wb.Worksheets(wb.Worksheets.Count))
SetWorkSheet.Name = SheetName
Else
SetWorkSheet.UsedRange.Clear '<--| clear preceeding values in already existent sheet
End If
End Function
There is no need to iterate over the list twice. GetWorkSheet create the new worksheets for you if they don't exist and handle any errors.
Sub HOBO_Split_v2()
Application.ScreenUpdating = False
Dim cell As Range, days As Range
Dim lFirstRow As Long, Lastrow As Long
Dim SheetName As String
Dim ws As Worksheet
With Sheets("Full Data Set")
Lastrow = Range("C" & Rows.Count).End(xlUp).Row
Set days = .Range("C5:C" & Lastrow)
For Each cell In days
If c.Text <> SheetName Or c.Row = Lastrow Then
If lFirstRow > 0 Then
Set ws = getWorkSheet(SheetName)
.Range("A" & lFirstRow, "A" & cell.Row).EntireRow.Copy ws.Range("A1")
End If
SheetName = c.Text
lFirstRow = i
End If
Next
End With
Application.ScreenUpdating = True
End Sub
Function getWorkSheet(SheetName As String) As Worksheet
Dim ws As Worksheet
On Error Resume Next
Set ws = Worksheets(SheetName)
If ws Is Nothing Then
Set ws = Worksheets.Add(after:=ActiveSheet)
ws.Name = SheetName
End If
On Error GoTo 0
Set getWorkSheet = ws
End Function
I'm trying to figure out how to copy a dynamic range into a new workbook. The actual project is to generate monthly budget reports based on the user's choice of month. The overarching system tracks a number of budget lines, where each line has its own sheet, and each sheet holds 12 tables for the fiscal year for expenses to be input; it all feeds back into an annual budget sheet. Upon the user picking a month, a new workbook will be created, mirroring the number of sheets and filling each sheet with that month's table. Each table is a dynamic range.
What I've got below is a dry run to work out the mechanics, but the problem is that I cannot get the dynamic range to paste correctly:
Sub pasting()
On Error Resume Next
Dim x As Workbook
Dim y As Workbook
'set the budget tracking system as the active workbook
Set x = Workbooks("Save and copying proof of concept.xlsm")
'activate budget tracking system
x.Activate
Set y = Workbooks.Add
Dim z As Range
Dim w As Range
'test copying two cells in two sheets into new sheets in the new workbook
Set z = Workbooks("Save and copying proof of concept.xlsm").Sheets("Sheet1").Range("A1")
Set w = Workbooks("Save and copying proof of concept.xlsm").Sheets("Sheet2").Range("A1")
'call saveas option for monthly workbook
With y
Call save_workbook_newName
End With
'add 8 sheets to new workbook for 8 budget lines
Dim v As Worksheet
Dim i As Integer
For i = 1 To 7
Sheets.Add
Next i
'copy the specified range from the original sheet and into the newly created workbook.
z.Copy
y.Sheets("Sheet1").Range("A1").PasteSpecial Paste:=xlPasteValues
w.Copy
y.Sheets("Sheet2").Range("A1").PasteSpecial Paste:=xlPasteValues
'copy a dynamic range to a new workbook
x.Worksheets("Sheet3").Activate
Dim xRow As Long, xColumn As Long
'determine the row and column limits of the dynamic range
Range("A100").End(xlUp).Select
xRow = ActiveCell.Row
Range("D").End(xlToLeft).Activate
xColumn = ActiveCell.Column
'select the range specified by the dynamic boundaries
Range(Cells(1, 1), Cells(xRow, xColumn)).Select
Selection.Copy
'activate newly created workbook
y.Worksheets("Sheet3").Activate
'paste into the new workbook
Selection.PasteSpecial Paste:=xlPasteAll, operation:=xlNone, SkipBlanks:=False, _
Transpose:=False
End Sub
Sub save_workbook_newName()
Dim workbook_name As Variant
'display the SaveAs dialog box
'once a name is provided, the GetSaveAsFilename method gets the particular name and _
'assigns that name to the workbook_name variable
workbook_name = Application.GetSaveAsFilename
'if the user provides a filename, the true condition is executed, and if not (presses Cancel), the false condition is executed.
If workbook_name <> False Then
'the application.acriveworkbook property returns the workbooks to the current active window
'saves the file with the file name given by the user.
ActiveWorkbook.SaveAs Filename:=workbook_name & "xlsx"
Else
ActiveWorkbook.Close
End If
End Sub
This bit is the problematic code:
Range("A100").End(xlUp).Select
xRow = ActiveCell.Row
Range("D").End(xlToLeft).Activate
xColumn = ActiveCell.Column
'select the range specified by the dynamic boundaries
Range(Cells(1, 1), Cells(xRow, xColumn)).Select
It essentially only copies column A, even if it's told to activate column D and choose everything to the left of it (Columns A to C hold random numbers).
Using this method for selecting a dynamic range did not yield good results:
LR = Range("D1000").End(xlUp).Row
Set R1 = Range("D1:E" & LR)
Thanks, and I appreciate your help in this respect!
Another approach using .Resize. I think this method is a bit better than #Thomas Inzina because it goes along column and row headers (the .End methods) which are likely to not have empty cells. In Thomas'es example, if your data has empty cells in the last column, the code will copy incomplete table.
Sub copyTableIntoNewWorksheet()
' locate the dynamic range / table
Dim rngTable As Range
With ActiveSheet.[b2] ' top left cell of the dynamic range
Set rngTable = .Resize(Range(.Offset(0), .End(xlDown)).Rows.Count, _
Range(.Offset(0), .End(xlToRight)).Columns.Count)
End With
' create new worksheet
Dim wsNew As Worksheet
Set wsNew = Worksheets.Add
wsNew.Name = "New Sheet"
' copy table to new worksheet
rngTable.Copy wsNew.[a1] ' top left cell where to copy the table to
End Sub
The Range object can take two parameters Range([Cell1],[Cell2). Gereerally, you'll use the top left cell as first parameter and the bottom right cell as the second.
The first parameter of your code is Cells(1, 1) and the second is Cells(xRow, xColumn). The range will extend from Row 1 Column 1 to Row xRow, Column xColumn.
Range(Cells(1, 1), Cells(xRow, xColumn))
There is no need to select a range when copying and pasting. We can chain ranges methods together.
Here we set a range that starting in D100 extending to the leftmost column and then down to the last used cell in the list. We then copy it and paste it into y.Worksheets("Sheet3").Range("A1").
Foe example:
Dim rw As Long, Cell1 As Range, Cell2 As Range
Dim y As Workbook
Set x = Workbooks.Add
Set y = Workbooks("Book5.xlms")
rw = 100
Set Cell1 = Range("A" & rw)
Set Cell2 = Range("A" & rw).End(xlToRight).End(xlDown) 'This is the bottom left cell in the table
Set Target = Range(Cell1, Cell2)
Target.Copy x.Worksheets("Sheet1").Range("A1")
We can do all this on 1 line like this:
rw = 100
Range("D" & rw, Range("D" & rw).End(xlToRight).End(xlDown)).Copy y.Worksheets("Sheet3").Range("A1")
I have an excel with multiple sheets and would like to copy or better say want to extend the last column every month.
Eg:-
I have a sheet with sheet named sheet1,sheet2,sheet3,sheet4,sheet5...every sheet at the end of the month has formulas.Once a month is over I would like to add a new column with new month and copying the existing formula to the new column.Let say I have last month Jan and I need VBA to add new column with month as Feb and copy all the formula to the new column.
Sometimes I also need to copy multiple column (eg:-Column C-J) and replicate the next 8 column with new month and formula.
Tried with recording macro but the issue is it doesn't create a new column for every month it just copy paste it in same column rather than creating a new one for every month
It is difficult to understand the problem without seeing the formulas.
It sounds like you could start by using the AutoFill. You could do this manually by selecting the range you want to copy and dragging the cross in the bottom right corner. This will update the month automatically.
You can achieve this with VBA, such as:
Public Sub copyRange()
Dim rngSource As Range
Dim rngDestination As Range
rngSource = ActiveSheet.Range("A1:A20")
rngDestination = ActiveSheet.Range("B1:B20")
rngSource.AutoFill Destination:=rngDestination
End Sub
Either way, I can't tell how to reset the formulae for the new months without seeing the cell code.
UPDATE: To AutoFill multiple columns on multiple tabs
Public Sub copySpecifiedColumns()
copyRanges InputBox("How many columns do you wish to copy?", "Copy Columns", "1")
End Sub
Private Sub copyRanges(copyCols As Byte)
Dim ws As Worksheet, lastCol As Integer, lastRow As Integer
Dim rngSource As Range, rngDestination As Range
Dim sheetList As Variant
sheetList = Array("Sheet1", "Sheet2", "Sheet3", "Sheet4", "Sheet5")
For Each ws In ThisWorkbook.Sheets
If (UBound(Filter(sheetList, ws.Name)) > -1) Then
lastCol = ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column
lastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
Set rngSource = ws.Range(ws.Cells(1, lastCol - copyCols + 1), _
ws.Cells(lastRow, lastCol))
Set rngDestination = ws.Range(ws.Cells(1, lastCol - copyCols + 1), _
ws.Cells(lastRow, lastCol + copyCols))
rngSource.AutoFill rngDestination
End If
Next ws
End Sub
I Agree it's a bit difficult to understand what you are trying to achieve here. From what I understand if you want to make a copy of last column in the next column in each sheet and change the 1st cell of that column to the month at the time. This code can help.
Sub copy_col()
Dim lColumn As Long
For Each Sheet In Worksheets
lColumn = Sheet.Cells(1, Columns.Count).End(xlToLeft).Column
Sheet.Columns(lColumn).Copy Sheet.Columns(lColumn + 1)
Sheet.Cells(1, lColumn + 1).Value = Month(Now())
Next Sheet
End Sub
If this is not what you want then please explain your problem more briefly.
Thanks
Extend List and Update Formula
Usage
ExtendList 5, "Sheet1", "Sheet3"
Where
1. 5, is the Column to Duplicate to the next empty Column
2. "Sheet1" is the sheet referenced in the original formula
3. "Sheet3" is the replace sheet name
Original Formula
=Sheet1!$A10
New Formula
=Sheet3!$A10
Sub ExtendList(SourceColumn As Long, OriginalSheetName As String, NewSheetName As String)
On Error Resume Next
Dim newColumnNumber As Integer
Worksheets(NewSheetName).Name = NewSheetName
If Err.Number <> 0 Then
Err.Clear
Exit Sub
End If
On Error GoTo 0
newColumnNumber = Range(Cells(1, Columns.Count), Cells(Rows.Count, Columns.Count)).End(xlToLeft).Offset(, 1).Column
Columns(SourceColumn).Copy Columns(newColumnNumber)
Columns(newColumnNumber).Replace What:=OriginalSheetName, Replacement:=NewSheetName, lookat:=xlPart, _
SearchOrder:=xlByColumns, MatchCase:=True, SearchFormat:=False, _
ReplaceFormat:=False
End Sub
This will only work if the column reference is absolute:
Correct
$A1 or $A$2
Incorrect
A1 or A$1
I'm really new to VBA and need some assistance in copying data from one single column, with evenly spaced partitions between data in the same column and pasted as rows.
I have an excel sheet with 300 business cards and are placed as in image 1.
Each business card is one highlighted block as in this example:
I need a VBA code to copy the data in column C and place as rows under the headers A,B,C,D,E,F.
Is there a VBA code that can do such a thing?
Any help is very much appreciated!!!
This should work.
Option Explicit
Sub TransposeBusinessCardData()
Dim BusinessCardDataSheet As Worksheet
'Replace BusinessCardSheet with the sheet name of your sheet
Set BusinessCardDataSheet = ThisWorkbook.Sheets("BusinessCardSheet")
Dim ResultSheet As Worksheet
'Replace ResultSheet with the sheet name of the sheet you want to paste the data in
Set ResultSheet = ThisWorkbook.Sheets("ResultSheet")
Dim LastRow As Long
LastRow = BusinessCardDataSheet.Cells(BusinessCardDataSheet.Rows.Count, "C").End(xlUp).Row
Dim RowReference As Long
Dim BusinessCardData As Range
Dim ResultRowRef As Long
'To paste from Row 2 on the ResultSheet
ResultRowRef = 2
'Step 7 Because there is 7 Rows between the start of each Business card
For RowReference = 2 To LastRow Step 7
BusinessCardDataSheet.Activate
Set BusinessCardData = BusinessCardDataSheet.Range(Cells(RowReference, "C"), Cells(RowReference + 5, "C"))
BusinessCardData.Copy
ResultSheet.Cells(ResultRowRef, "B").PasteSpecial Paste:=xlPasteAll, _
Operation:=xlNone, SkipBlanks:=False, _
Transpose:=True
ResultRowRef = ResultRowRef + 1
Next RowReference
End Sub