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
Related
I'm not sure how the logic of loop works.
I have a table at sheet 1 with 105 rows and 120 columns.
I want to do a loop, start with cell J6, copy a range of 100 rows and 16 columns. And transpose and paste at sheet 2 (B1:CW16). Then start with cell K6, copy another range of 100 rows and 16 columns and transpose and paste at sheet 2(B19:CW34). Then start with cell L6 (another 100 rows and 16 columns)and paste at sheet 2. (paste at every 18 rows in sheet 2)
I searched online and have the following code:
Sub transpose()
Dim ColNum As Long
Dim i as long
For ColNum = 10 To 108
LR = Range("B" & Rows.Count).End(xlUp).Row
Sheet1.Activate
Range((Cells(6, ColNum)), (Cells(105, ColNum + 15))).copy
'Transpose
Sheet2.Activate
For i = 1 To LR Step 18
Cells(i, 2).Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone,
SkipBlanks:=False, transpose:=True
Next i
Next ColNum
End Sub
This code does not give me what I want. this code copy a range in sheet 1 and paste multiple times in sheet 2 and then copy a second range in sheet 1 and replace everything in sheet 2. How do I modify the code so that I can copy the first range in sheet1, paste to sheet 2 range B1:CW16, then copy the second range in sheet1, and paste to sheet 2 range B19:CW34. (a step of 18 rows at sheet 2)?
Not the most elegant but this should help. I have tried to make the terms as descriptive as possible to help you understand what is going on at each stage.
You can modify these to transpose different numbers of columns and rows from different ranges in the source sheet.
Where to copy from: startCell
When to end copying from: endCell
Where to start pasting to: targetStartCell
How much to transpose: copyRowSize , copyColumnSize
Steps to govern next row destination for transpose: rowStep
Option Explicit
Public Sub TransposeToOtherSheet()
Dim wb As Workbook
Set wb = ThisWorkbook
Dim ws As Worksheet
Set ws = wb.Worksheets("Sheet1") 'change as appropriate
Const numberOfRows As Long = 105
Const numberOfColumns As Long = 120
Const copyRowSize As Long = 100
Const copyColumnSize As Long = 16
Const rowStep As Long = 18
Dim startCell As Range
Dim endCell As Range
Set startCell = ws.Range("J6")
Set endCell = ws.Range("DY6")
Dim targetSheet As Worksheet
Dim targetStartCell As Range
Dim targetRow As Long
Dim targetColumn As Long
Set targetSheet = wb.Worksheets("Sheet2") 'change as appropriate
Set targetStartCell = targetSheet.Range("A1")
targetRow = targetStartCell.Row
targetColumn = targetStartCell.Column
Dim currentColumn As Long
Dim headerRow As Long
headerRow = startCell.Row
Dim targetRowCounter As Long
For currentColumn = startCell.Column To endCell.Column
If targetRowCounter = 0 Then
targetStartCell.Resize(copyColumnSize, copyRowSize) = Application.WorksheetFunction.Transpose(ws.Cells(headerRow, currentColumn).Resize(copyRowSize, copyColumnSize))
Else
' Debug.Print "destination range " & targetSheet.Cells((targetRowCounter * rowStep) + targetRow, targetColumn).Resize(copyColumnSize, copyRowSize).Address
targetSheet.Cells((targetRowCounter * rowStep) + targetRow, targetColumn).Resize(copyColumnSize, copyRowSize) = Application.WorksheetFunction.Transpose(ws.Cells(headerRow, currentColumn).Resize(copyRowSize, copyColumnSize))
End If
targetRowCounter = targetRowCounter + 1
Next currentColumn
End Sub
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.
As you can see in the screenshot (I've provided the screenshot link below), I have an excel sheet with lots of numerical data. I have used conditional formatting to highlight some of the data. My end goal is to copy these highlighted data and paste it in vertical order in a new sheet. However, the problem I face is that these data are staggered among many rows and columns. So for instance, there will be a highlighted data in row 120 column BBQ. I want to copy & paste all of these spread out highlighted data in a new sheet in vertical order. I just can't figure out what code to type :(
Any sort of help will be appreciated. Thank You!
Try the below. Make changes to sheet and range names as needed. It loads the data into an array, tests if each point is less than or equal to 50 (moving down the rows, then across the columns ... but you can switch the For statements if you want) and if so, writes to a new sheet.
Sub CopyConditionalData()
Dim ws1 As Worksheet, ws2 As Worksheet
Set ws1 = Worksheets("Sheet1") ' change as needed
Set ws2 = Worksheets("Sheet2") ' change as needed
Dim rRng As Range
Set rRng = ws1.Range("A1:G100") 'change as needed
Dim aRng As Variant
aRng = rRng
Dim lRows As Long, lCols As Long
For lCols = 1 To rRng.Columns.Count
For lRows = LBound(aRng) To UBound(aRng)
If aRng(lRows, lCols) <= 50 Then
ws2.Range("A" & ws2.Rows.Count).End(xlUp).Offset(1) = aRng(lRows, lCols)
End If
Next
Next
End Sub
Assuming you have 120 rows and 100 columns data in Sheet1 and the highlighted color is yellow and the highlighted data has to be copied to Sheet2, then
Dim temp As Integer
temp = 1
For i = 1 To 120
For j = 1 To 100
Worksheets("Sheet1").Activate
If Cells(i, j).Interior.Color = RGB(255, 255, 0) Then
x = Cells(i, j).Value
Worksheets("Sheet2").Activate
Cells(temp, 1).Value = x
temp = temp + 1
End If
Next j
Next i
so .. just copy the values below 50 :]
set cell2 = Worksheets(2).Range("A1")
For Each cell in Worksheets(1).UsedRange
If Not IsNumeric(cell.Value) And cell.Value <= 50 Then
cell2.Value2 = cell.Value2
Set cell2 = cell2.Offset(1)
End If
Next
I suggest removing the Conditional Formatting, labelling the matrix (rows and columns) then unpivoting (for example as shown here).
Then flagging the rows by relevant decade (10, 20, 30 etc ... as in D1) and pivoting the created Table to suit.
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")
Hi I have code which is meant to
Loop through all worksheets which begin with "673"
Copy all the rows which have data from row 5 onwards
Paste the entries on the next empty row in the "Colours" worksheet
I'm having the following issues:
Code only runs in the worksheet that is active
Doesn't loop through all worksheets
When it pastes in the "Colours" worksheet, it pastes directly over the headings in row 2. The first blank row is row 3 onwards and I would like the logic to paste at the next available blank row as it loops through the sheets.
Sub Consolidate()
Dim lastrow As Long
Dim report As Worksheet
Set report = Excel.ActiveSheet
For Each Sheet In ActiveWorkbook.Worksheets
If InStr(Sheet.Name, "673") > 0 Then
With report
.Range(.Cells(5, "K"), .Cells(.Rows.Count, "K").End
(xlUp)).EntireRow.Copy
End With
Worksheets("Colours").Select
lastrow = Worksheets("Colours").Cells(Worksheets("Colours").Rows.Count, 1).End(xlUp).Row
Worksheets("Colours").Cells(lastrow + 1, 1).Select
ActiveSheet.Paste
End If
Next
End Sub
Your help would be greatly appreciated.
KS is right, to get your code functioning you just need to reference the sheet. I'd started modifying it further so I'll post what I've done in totality:
Firstly I removed the 'Set report = ' line, that's not needed (alternatively you could have 'Set report' at the beginning of the loop, but it's easier to work directly 'With Sheet' as KS says).
CHANGED1 = You said it should loop through worksheets that 'begin' with 673, so this new line checks for the first three characters matching 673, rather than just looking to see if 673 appears anywhere in the sheet name.
NEW = Activates the sheet, this makes the next copy command work.
CHANGED2 = With Sheet as explained above.
CHANGED3 = You said it should copy the rows that have data from row 5 onwards (previously your code would copy rows 1-5).
Sub Consolidate()
Dim lastrow As Long
Dim report As Worksheet
For Each Sheet In ActiveWorkbook.Worksheets
If Left(Sheet.Name, 3) = "673" Then 'CHANGED1
Worksheets(Sheet.Name).Select 'NEW
With Sheet 'CHANGED2
.Range("A5", Range("A" & 65536).End(xlUp)).EntireRow.Copy 'CHANGED3
End With
Worksheets("Colours").Select
lastrow = Worksheets("Colours").Cells(Worksheets("Colours").Rows.Count, 1).End(xlUp).Row
Worksheets("Colours").Cells(lastrow + 1, 1).Select
ActiveSheet.Paste
End If
Next
End Sub
Hope this helps!
try the following code
Sub Consolidate()
Dim sheet As Worksheet, coloursSheet As Worksheet
Set coloursSheet = ActiveWorkbook.Worksheets("Colours")
For Each sheet In ActiveWorkbook.Worksheets
If Left(sheet.Name, 3) = "673" Then
sheet.Range("K5:K" & sheet.Cells(sheet.Rows.Count, "K").End(xlUp).Row).SpecialCells(xlCellTypeConstants).EntireRow.Copy _
Destination:=coloursSheet.Cells(coloursSheet.Rows.Count, "A").End(xlUp).Offset(1)
End If
Next
End Sub
it:
avoids useless selections and variables
copies non blank cells only (assuming data are "constants", i.e. not formulas)