I have created the following macro
I have data going all the way to row 3710 in the master data sheet - and I do not know how to force this macro to loop and include all the data
Sub Macro3()
'
' Macro3 Macro
'
'
Range("A1:A2").Select
Selection.Copy
Sheets("Sheet2").Select
Range("A1:B1").Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=True
Sheets("Sheet1").Select
Range("A3:A4").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Sheet2").Select
Range("A2:B2").Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=True
End Sub
You can do this with a for loop. Also Copy/Paste is something we generally shy away from in VBA as well as .SELECT and .ACtivate. Those are functions that a human performs, but the computer can just set cells equal to other cell's values like:
Sheets("Sheet1").Cells(1, 1).value = Sheets("Sheet2").Cells(1,1).value
Which says Cell "A1" in Sheet1 should be set to whatever the value is in Sheet2 Cell "A1".
Changing things around, implementing a loop to perform your transpose, and using some quick linear regression formula to determine which row to write to we get:
Sub wierdTranspose()
'Loop from row 1 to row 3710, but every other row
For i = 1 to 3710 Step 2
'Now we select from row i and row i + 1 (A1 and A2, then A3 and A4, etc)
'And we put that value in the row of sheet2 that corresponds to (.5*i)+.5
' So if we are picking up from Rows 7 and 8, "i" will be 7 and (.5*i)+.5 will be row 4 that we paste to
' Then the next iteration will be row 9 and 10, so "i" will be 9 and (.5*i)+.5 will be row 5 that we paste to
' and on and on until we hit 3709 and 3710...
Sheets("Sheet2").Cells((.5*i)+.5, 1).value = Sheets("Sheet1").Cells(i, 1).value
Sheets("Sheet2").Cells((.5*i)+.5, 2).value = Sheets("Sheet1").Cells(i+1, 1).value
Next i
End Sub
Bulk data is best transferred via VBA arrays, with no copy/paste required.
Something like this:
Sub SplitColumn()
Dim A As Variant, B As Variant
Dim i As Long
Dim ws1 As Worksheet, ws2 As Worksheet
Set ws1 = Sheets(1)
Set ws2 = Sheets(2)
With ws1
A = .Range(.Cells(1, 1), .Cells(3710, 1))
End With
ReDim B(1 To 1855, 1 To 2)
For i = 1 To 1855
B(i, 1) = A(2 * i - 1, 1)
B(i, 2) = A(2 * i, 1)
Next i
With ws2
.Range(.Cells(1, 1), .Cells(1855, 2)).Value = B
End With
End Sub
Related
I have two Workbooks that I need to copy/paste data from one workbook into the next available row in another workbook. The code I have below is almost working. You see, there is a total row at the bottom of the destination workbook. So, I'm trying to figure out how to insert a row at the next available row from the top, but instead, my code inserts the data below the totals row.
Here's how it looks in Excel. I'm trying to insert what would be Row C, but instead it inserts below the "Totals" row:
Row A 1 2 3 4
Row B 2 3 4 5
<-----Trying to Insert Here---------->
Totals 3 5 7 9
Here's my code"
:
Sub sbCopyToDestination()
Dim SourceRange As Range
Set SourceRange = ThisWorkbook.Worksheets("Sheet1").Range("f34:l34")
Dim NextFreeCell As Range
Set NextFreeCell = Workbooks("Destination.xlsm").Worksheets("Sheet1").Cells(Rows.Count, "B").End(xlUp).Offset(RowOffset:=1)
SourceRange.Copy
NextFreeCell.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
ThisWorkbook.Save
End Sub
Try the next code, please. It also updates the total, to include the pasted values.
Dim SourceRange As Range, destSh As Worksheet, NextFreeCell As Range
Set SourceRange = Range("f34:l34") ' ThisWorkbook.Worksheets("Sheet1").Range("f34:l34")
Set destSh = Workbooks("Book1").Worksheets("Sheet1") ' Workbooks("Destination.xlsm").Worksheets("Sheet1")
Set NextFreeCell = destSh.cells(Rows.count, "B").End(xlUp)
Application.CutCopyMode = 0
NextFreeCell.EntireRow.Insert xlDown
NextFreeCell.Offset(-1).Resize(, 2).Value = SourceRange.Value
'if you do not need to update the sum formula with the new inserted row, coamment the next row
NextFreeCell.Formula = UpdateFormula(NextFreeCell)
NextFreeCell.Offset(, 1).Formula = UpdateFormula(NextFreeCell.Offset(, 1))
ThisWorkbook.Save
End Sub
Function UpdateFormula(rng As Range) As String
Dim x As String
x = rng.Formula
UpdateFormula = Replace(x, Split(x, ":")(1), _
Replace(Split(x, ":")(1), rng.Row - 2, rng.Row - 1))
End Function
Try this
Sub sbCopyToDestination()
Dim SourceRange As Range
Set SourceRange = ThisWorkbook.Worksheets("Sheet1").Range("f34:l34")
Dim NextFreeCell As Range
Set NextFreeCell = Workbooks("Destination.xlsm").Worksheets("Sheet1").Cells(Rows.count, "B").End(xlUp) ' No offset
With SourceRange
NextFreeCell.Resize(.Rows.count, 1).EntireRow.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
NextFreeCell.Resize(.Rows.count, .Columns.count).Value = .Value
End With
ThisWorkbook.Save
End Sub
I am looking to create a macro which would allow me to copy and paste data from one column and then transpose that data over 2 columns in the right order
I have recorded a macro while doing the process manually
Range("G3").Select
Application.CutCopyMode = False
Selection.Copy
Range("G2:G7").Select ' (The column range I want to copy)
Application.CutCopyMode = False
Selection.Copy
Range("I1").Select ' (Row where the range of G2:G7) is now transposed)
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=True
Range("H2:H7").Select ' (The second column range I want to copy)
Application.CutCopyMode = False
Selection.Copy
Range("I2").Select ' (Second Row where the range of H2:H7) is now transposed)
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=True
Range("H8:H13").Select ' (The third column range I want to copy)
Application.CutCopyMode = FalseSelection.Copy
Range("I3").Select' ( Third Row where the range of H8:H13) is now transposed)
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=True
The problem is that this code only works up to certain number of rows (up till H13 for example), but if I want to this repeat this process up to row H600 (range of H600:H605) and pasting to I31 for example without copying and pasting this code hundreds of times, is there a way I can do this?
This is what I mean by example
Column H
Star
Greenwood
Titon
Humford
converted to
Column I | Column J**
Star | Greenwood
titon | Humford
Here's an alternative to Copy/Paste - using Variant Arrays. This will be much faster for large data sets.
Sub Demo()
Dim rng As Range
Dim Src As Variant
Dim Dst As Variant
Dim GroupSize As Long
Dim Groups As Long
Dim iRow As Long
Dim iCol As Long
Dim iDst As Long
Dim SrcStartRow As Long
Dim SrcColumn As Long
Dim DstStartRow As Long
Dim DstColumn As Long
' Set up Parameters
GroupSize = 2
SrcStartRow = 2
SrcColumn = 8 'H
DstStartRow = 1
DstColumn = 9 'I
With ActiveSheet 'or specify a specific sheet
' Get Reference to source data
Set rng = .Range(.Cells(SrcStartRow, SrcColumn), .Cells(.Rows.Count, SrcColumn).End(xlUp))
' Account for possibility there is uneven amount of data
Groups = Application.RoundUp(rng.Rows.Count / GroupSize, 0)
If rng.Rows.Count <> Groups * GroupSize Then
Set rng = rng.Resize(Groups * GroupSize, 1)
End If
'Copy data to Variant Array
Src = rng.Value2
'Size the Destination Array
ReDim Dst(1 To UBound(Src, 1) / GroupSize, 1 To GroupSize)
'Loop the Source data and split into Destination Array
iDst = 0
For iRow = 1 To UBound(Src, 1) Step GroupSize
iDst = iDst + 1
For iCol = 1 To GroupSize
Dst(iDst, iCol) = Src(iRow + iCol - 1, 1)
Next
Next
' Move result to sheet
.Cells(DstStartRow, DstColumn).Resize(UBound(Dst, 1), UBound(Dst, 2)).Value = Dst
End With
End Sub
Before
Well, you are not really transposing, but I would use this method. I start at 2 to leave the first in place, then basically move the next one over and delete all the empty spaces at the end.
Sub MakeTwoColumns()
Dim x As Long
For x = 2 To 500 Step 2
Cells(x, 6) = Cells(x, 5)
Cells(x, 5).ClearContents
Next x
Columns(5).SpecialCells(xlCellTypeBlanks).Delete
Columns(6).SpecialCells(xlCellTypeBlanks).Delete
End Sub
After
My code is supposed to select all of the items in A-H from the top of the sheet to the bottom most row containing text in the J column. However, now all it does is select the top row. This code has worked fine elsewhere for other purposes, but when I run it here it only selects the top row.
Here is the code and what it currently does. The commented out bit does the same when it is ran in the place of the other finalrow =statement.
Option Explicit
Sub FindRow()
Dim reportsheet As Worksheet
Dim finalrow As Integer
Set reportsheet = Sheet29
Sheet29.Activate
'finalrow = Cells(Rows.Count, 10).End(xlUp).Row
finalrow = Range("J1048576").End(xlUp).Row
If Not IsEmpty(Sheet29.Range("B2").Value) Then
Range(Cells(1, 1), Cells(finalrow, 8)).Select
End If
End Sub
This is the excerpt of code with a row counter that works.
datasheet.Select
finalrow = Cells(Rows.Count, 1).End(xlUp).Row
''loop through the rows to find the matching records
For i = 1 To finalrow
If Cells(i, 1) = item_code Then ''if the name in H1 matches the search name then
Range(Cells(i, 1), Cells(i, 9)).Copy ''copy columns 1 to 9 (A to I)
reportsheet.Select ''go to the report sheet
Range("A200").End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False ''find the first blank and paste info there
datasheet.Select ''go back to the data sheet and continue searching
End If
Next i
You can try this:
Option Explicit
Sub FindRow()
' always use Longs over Integers
Dim finalrow As Long: finalrow = 1
' you might not need this line tbh
Sheet29.Activate
With Sheet29
' custom find last row
Do While True
finalrow = finalrow + 1
If Len(CStr(.Range("J" & finalrow).Value)) = 0 Then Exit Do
Loop
' Len() is sometimes better then IsEmpty()
If Len(CStr(.Range("B2").Value)) > 0 Then
.Range(.Cells(1, 1), .Cells((finalrow - 1), 8)).Select
End If
End With
End Sub
This is my first attempt to write vba code. I have a excel workbook with 19 worksheets (FVal.xls), each of them composed of 130 rows and 15 columns with data.
If I find a specific value ("Fla") in the fourth column, I want to copy data in this row from column 10 to column 15 and paste it in row 3, columns 10 - 15 in each sheet.
Code is running but it leaves blank cells in the position of copied cells.
Here is my code:
Option Explicit
Sub FinCop()
Dim wb1 As Workbook
Dim ws As Worksheet
Dim i As integer
Set wb1 = Workbooks.Open("C:\FVal.xls")
For Each ws In wb1.Worksheets
i = 1
Do While ws.Cells(i, 4).Text <> "Fla"
i = i + 1
Loop
ws.Range(ws.Cells(i, 10), ws.Cells(i, 15)).Copy
ws.Range(ws.Cells(3, 7), ws.Cells(3, 15)).PasteSpecial Paste:=xlPasteValues, _
Operation:=xlNone, _
SkipBlanks:=True, _
Transpose:=False
Next ws
End Sub
I have an Excel Workbook (named Peak) with 100 sheets (each Sheet starts with Sheet1 followed by a unique name, Sheet1AA), I want to copy one column from each Peak Sheet and paste into a new Workbook (named Table) using transpose, so the Table will have 100 rows of data from the Peak Workbook Sheets. Below is an example where two Sheets are copied and then pasted, with the second Sheet (Sheet1BB) pasted below the first Sheet (Sheet1AA) in the Table. I know I can record a macro as I do the copy/paste-transpose, but hoping there is a way to write a macro to do the copy/paste consecutively/in order from the Peak Workbook (Sheet1AA-Sheet1ZZ) to the Workbook Table to give 100 rows of data, with data from Sheet1AA the first row and Sheet1ZZ the last row in the Table.
Thank you
Windows("Peak.xlsm").Activate
Sheets("Sheet1AA").Select
Range("O6:O150").Select
Application.CutCopyMode = False
Selection.Copy
Windows("Table.xlsm").Activate
Range("E4:AB4").Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=True
Windows("Peak.xlsm").Activate
Sheets("Sheet1BB").Select
Range("O6:O150").Select
Application.CutCopyMode = False
Selection.Copy
Windows("Table.xlsm").Activate
Range("E5:AB5").Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=True
Untested:
Dim r As Long, sht As Worksheet
r = 4
For Each sht In Workbooks("Peak.xlsm").Worksheets
sht.Range("O6:O150").Copy
Workbooks("Table.xlsm").Sheets(1).Cells(r, "E").PasteSpecial Transpose:=True
r = r + 1
Next sht
Since OP's need to maintain pasted data ordered by parent sheet name, here follows two possible codes:
temporary helper column
this approach
inserts a (temporary) column right before column "E" where to store sheet names, while corresponding data are written from the next column to rigthwards.
sorts the pasted range on sheet names in (temporary) column "E"
deletes temporary column
Option Explicit
Sub Main()
Dim iSht As Long
Dim sht As Worksheet
With Workbooks("Table.xlsm").Worksheets(1)
.Columns("E").Insert '<--| insert temporary helper column
For Each sht In Workbooks("Peak.xlsm").Worksheets '<--| loop through sheets
sht.Range("O6:O150").Copy
.Cells(4 + iSht, "E") = sht.Name '<--| write sheet name in temporary helper column
.Cells(4 + iSht, "F").PasteSpecial Transpose:=True '<--| write data from the next colum rightwards
iSht = iSht + 1
Next sht
With .Cells(4, "E").Resize(iSht, 146) '<--| consider temporary helper column cells containing sheet names
.Sort key1:=.Cells(1, 1), order1:=xlAscending '<--| sort them
.EntireColumn.Delete '<--| remove temporary helper column
End With
End With
End Sub
array with ordered sheet names
this requires writing them down in a temporary sheet (in ThisWorkbook), sorting them and reading them back (see Function GetSortedWsNames())
Sub Main2()
Dim i As Long: i = 4
Dim wb As Workbook
Dim el As Variant
Set wb = Workbooks("Peak.xlsm")
With Workbooks("Table.xlsm").Worksheets(1)
For Each el In GetSortedWsNames(wb)
wb.Worksheets(el).Range("O6:O150").Copy
.Cells(i, "E").PasteSpecial Transpose:=True
i = i + 1
Next el
End With
End Sub
Function GetSortedWsNames(wb As Workbook) As Variant
Dim ws As Worksheet
Dim iSht As Long
Set ws = ThisWorkbook.Worksheets.Add
With wb
For iSht = 1 To .Worksheets.Count
ws.Cells(iSht, 1) = .Worksheets(iSht).Name
Next iSht
End With
With ws.Cells(1, 1).Resize(iSht - 1)
.Sort key1:=ws.Cells(1, 1), order1:=xlAscending
GetSortedWsNames = Application.Transpose(.Cells)
End With
Application.DisplayAlerts = False
ws.Delete
Application.DisplayAlerts = True
End Function