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
Related
My goal is to copy and paste rows that meet a certain criteria into a table in another workbook.
My VBA works perfectly except for it pastes in the empty cell below the table. Not in the empty cells below the headers within the table.
PS. I know using select is generally frowned upon, but I needed to use fairly basic syntax so that if the next person needs to modify this and is unfamiliar with VBA they can.
Sub Export()
Sheets("Export Format").Select
Cells(13, "D").Calculate
With Range("A1", Cells(Rows.Count, "L").End(xlUp)) 'reference its column A:G cells from row 1 (header) down to last not empty one in column "A"
.AutoFilter Field:=6, Criteria1:="<>0" ' filter referenced cells on 6th column with everything but "0" content
If Application.WorksheetFunction.Subtotal(103, .Columns(1)) > 1 Then
.Offset(1).Resize(.Rows.Count - 1).SpecialCells(xlCellTypeVisible).Copy ' copy filtered cells skipping headers
With Workbooks.Open(Filename:="Z:\Tracking\Database.xlsx").Sheets("Sheet1") 'open wanted workbook and reference its wanted sheet
.Cells(.Rows.Count, 1).End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone _
, SkipBlanks:=False, Transpose:=False 'paste filtered cells in referenced sheet from ist column A first empty cell after last not empty one
.Parent.Close True 'Save and closes referenced workbook
End With
Application.CutCopyMode = False
End If
End With
On Error Resume Next
Sheets("Export Format").ShowAllData 'Clears Filters
On Error GoTo 0
Sheets("Export Format").Select 'Brings back to Main request sheet
End Sub
Try using a property of the table such as InsertRowRange
Sub Export()
Const DBFILE = "Z:\Tracking\Database.xlsx"
Dim wb As Workbook, wbDB As Workbook
Dim ws As Worksheet, tbl As ListObject
Dim rngFilter As Range, x, rng As Range
Set wb = ThisWorkbook
Set ws = wb.Sheets("Export Format")
x = Application.WorksheetFunction.Subtotal(103, ws.Columns(1))
If x <= 1 Then
ws.Select
Exit Sub
End If
' set filter range
With ws
.Range("D13").Calculate
' column A:L cells from row 1 (header)
' down to last not empty one in column "A"
Set rngFilter = .Range("A1", .Cells(Rows.Count, "L").End(xlUp))
End With
' open wanted workbook and reference its wanted sheet
Set wbDB = Workbooks.Open(DBFILE)
With wbDB.Sheets("Sheet1")
Set tbl = .ListObjects("Table1")
If tbl.InsertRowRange Is Nothing Then
Set rng = tbl.ListRows.Add.Range
Else
Set rng = tbl.InsertRowRange
End If
End With
' filter on 6th column with everything but "0" content
With rngFilter
.AutoFilter Field:=6, Criteria1:="<>0"
' copy filtered cells skipping headers
.Offset(1).Resize(.Rows.Count - 1).SpecialCells(xlCellTypeVisible).Copy
'paste filtered cells in referenced sheet
'from ist column A first empty cell after last not empty one
rng.PasteSpecial Paste:=xlPasteValues, _
Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
End With
wbDB.Close True 'Save and closes referenced workbook
ws.AutoFilterMode = False
ws.Select 'Brings back to Main request sheet
MsgBox "Ended"
End Sub
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 have 80 or so columns of data. I need just 21 columns.
In my output, I would like the 21 columns to be in a particular order. For example, I want the value from the cell AX2 from my source file to go to A2, BW2 to go to B2, etc.
The source data may differ from month to month and could have as little as 1 row of data or hundreds so I would like this to loop until no data is left.
I got a run time error 424 object required. I have only outlined the rules for two columns but will work on the rest when I get the proper set up.
Sub Macro1()
'
' Macro1 Macro
'
'
Sheet4.Select
Application.ScreenUpdating = False
row_count = 2
Do While Sheet2.Range("A" & row_count) <> ""
Range("AX2:AX1000").Select
Selection.Copy
ActiveWindow.ActivateNext
Range("A").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
ActiveWindow.ActivateNext
Range("BW2:BW1000").Select
Application.CutCopyMode = False
Selection.Copy
ActiveWindow.ActivateNext
Range("B").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
x = x + 1
ActiveWindow.ActivateNext
ActiveSheet.Next.Select
ActiveSheet.Next.Select
Loop
End Sub
I hope I didn't go too far. Try this subscript, it asks you to select a workbook, it will open the workbook, copy column B2 to last used Row on Column B, and paste it on the first workbook. Make sure to rename the CopyFromSheet and CopyToSheet on the code. Please read each line and try to understand what it is doing. Let me know if any questions.
Sub CopyPaste()
Dim openFile As FileDialog, wb As Workbook, sourceWb As Workbook
Dim CopyTo As String, CopyFrom As String
Dim lastRow As Long
Application.ScreenUpdating = False
Set wb = ThisWorkbook
Set openFile = Application.FileDialog(msoFileDialogFilePicker)
openFile.Title = "Select Source File"
openFile.Filters.Clear
openFile.Filters.Add "Excel Files Only", "*.xl*"
openFile.Filters.Add "All Files", "*.*"
openFile.Show
If openFile.SelectedItems.Count <> 0 Then
Set sourceWb = Workbooks.Open(openFile.SelectedItems(1), False, True, , , , True)
CopyFrom = "CopyFromSheetName"
CopyTo = "CopyToSheetName"
lastRow = sourceWb.Sheets(CopyFrom).Cells(Rows.Count, "B").End(Excel.xlUp).Row
sourceWb.Sheets(CopyFrom).Range("B2:B" & lastRow).Copy 'You can copy this Row and the Next and add as many as you want to copy the Columns Needed
wb.Sheets(CopyTo).Range("B1").PasteSpecial xlValues
Application.CutCopyMode = xlCopy
Else
MsgBox "A file was not selected"
End If
Application.ScreenUpdating = True
End Sub
I suggest you separate the copy logic from the setup of which columns to copy. That way it will be much easier to manage the setup.
In this code I have hard coded to Columns Pairs. Alternatively, you could put that data on a sheet and read it in.
Sub Demo()
'declare all your variables
Dim wsSource As Worksheet
Dim wsDest As Worksheet
Dim rSource As Range
Dim rDest As Range
Dim CP() As Variant 'Column Pairs array
Dim idx As Long
'Set up an array of Source and Destination columns
ReDim CP(1 To 21, 1 To 2) 'Adjust size to suit number of column pairs
CP(1, 1) = "AX": CP(1, 2) = "A"
CP(2, 1) = "BW": CP(2, 2) = "B"
'and so on
' Source and Destination don't have to be in the same Workbook
' This code assumes the Source (and Destination) worksbooks are already open
' You can add code to open them if required
' If the data is in the same book as the code, use ThisWorkbook
' If the data is in a different book from the code,
' specify the book like Application.Workbooks("BookName.xlsx")
' or use ActiveWorkbook
'Update the names to your sheet names
Set wsSource = ThisWorkbook.Worksheets("SourceSheetName")
Set wsDest = ThisWorkbook.Worksheets("DestSheetName")
' Notice that form here on the code is independent of the Sheet and Column names
'Loop the column pairs array
For idx = 1 To UBound(CP, 1)
'if the entry is not blank
If CP(idx, 1) <> vbNullString Then
'Get reference to source column cell on row 2
Set rSource = wsSource.Columns(CP(idx, 1)).Cells(2, 1)
'If that cell is not empty
If Not IsEmpty(rSource) Then
'If the next cell is not empty
If Not IsEmpty(rSource.Offset(1, 0)) Then
'extend range down to first blank cell
Set rSource = wsSource.Range(rSource, rSource.End(xlDown))
End If
'Get a reference to the destination range, from row 2, same size as source
Set rDest = wsDest.Columns(CP(idx, 2)).Cells(2, 1).Resize(rSource.Rows.Count)
'Copy the values
rDest.Value = rSource.Value
End If
End If
Next
End Sub
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
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