I have 7 tabs in an excel work book. The information in these tabs are all tables. I need to combine these tables so each one starts in the next empty column. The code that I've tried to make starts on the next empty row, instead of the next empty Column.
Basically, I want all of my headers from each table to all be contained in row 1 instead of starting in the next free row.
Sub Combine()
Dim J As Integer
Dim s As Worksheet
Dim NextEmptyCol As Long
NextEmptyCol = Cells.Find("*", [A1], , , xlByColumns, xlPrevious).Column + 1
Sheets(1).Select
Worksheets.Add ' add a sheet in first place
Sheets(1).Name = "Combined"
For Each s In ActiveWorkbook.Sheets
If s.Name <> "Combined" Then
Application.Goto Sheets(s.Name).[A1]
Selection.CurrentRegion.Select
Sheet.UsedRange.Clear
Selection.Copy Destination:=Sheets("Combined"). _
Cells(Columns.Count, 1).End(xlUp)(2)
End If
Next
End Sub
Your code Selection.Copy Destination:=Sheets("Combined").Cells(Columns.Count, 1).End(xlUp)(2) finds the next free row. To find the next free column:
LastCol = Sheets("Combined").Cells(1, Columns.Count).End(xlToLeft).Column
Selection.Copy Destination:=Sheets("Combined"). _
Cells(1, LastCol + 1)
Related
VBA Creating new sheets from unique column values in Sheet1 + bringing over adjacent row information
Hey all- I'm trying to a script that identifies the unique values in column E (data starts on row 1), creates a new sheet based on those unique values (also names the sheet per the value), and in the new sheet it creates it brings over the information corresponding rows in column A, C, D, and H -
I found this YouTube video that shows the process but instead of the script indentifying the unique values you have to manually input the keyword it is looking for and it only runs it once. I haven't been able to get the 'for loop' to run properly ...
https://www.youtube.com/watch?v=qGZQIl9JJk4&t=561s
Any help would be much appreciated-!
Private Sub CommandButton1_Click()
J = "Test"
Worksheets.Add().Name = J
Worksheets("Sheet1").Rows(1).Copy
Worksheets(J).Activate
ActiveSheet.Paste
Worksheets("Sheet1").Activate
a = Worksheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row
For i = 2 To a
If Worksheets("Sheet1").Cells(i, 5).Value = "XXXX" Then
Worksheets("Sheet1").Rows(i).Copy
Worksheets(J).Activate
b = Worksheets(J).Cells(Rows.Count, 1).End(xlUp).Row
Worksheets(J).Cells(b + 1, 1).Select
ActiveSheet.Paste
Worksheets("Sheet1").Activate
End If
Next
Application.CutCopyMode = False
ThisWorkbook.Worksheets("Sheet1").Cells(1, 1).Select
End Sub
Something like this:
Private Sub CommandButton1_Click()
Dim sht As Worksheet, c As Range, i As Long
Set sht = ThisWorkbook.Worksheets("Sheet1")
For i = 2 To sht.Cells(Rows.Count, 1).End(xlUp).Row
CopyDestination(sht.Cells(i, 5).Value).Resize(1, 5).Value = _
Array(sht.Cells(i, 5).Value, sht.Cells(i, 1).Value, _
sht.Cells(i, 3).Value, sht.Cells(i, 4).Value, _
sht.Cells(i, 8).Value)
Next
Application.CutCopyMode = False
End Sub
'Find the next "paste" destination on the appropriate sheet named "v"
' If sheet doesn't exist, create it
Function CopyDestination(v) As Range
Dim sht As Worksheet
On Error Resume Next
Set sht = ThisWorkbook.Sheets(v)
On Error GoTo 0
If sht Is Nothing Then '<< no existing matching sheet
With ThisWorkbook
Set sht = .Sheets.Add(after:=.Sheets(.Sheets.Count))
End With
sht.Name = v '<<< assumes "v" is valid as a worksheet name...
End If
'find the first empty cell in Col A
Set CopyDestination = sht.Cells(sht.Rows.Count, 1).End(xlUp).Offset(1, 0)
End Function
It's been a decade since I've written VBA and trying to reach out to see what I broke. I wrote a macro which copies data from one sheet to another, 1 column at a time for 4 different columns, and pastes it in the next free cell. This formula worked but I would like to adjust it to only copy certain data. Below is an example, I am trying to only copy A if the date value in E is equal to the input date value you enter when the macro starts. I am having most trouble balancing the If/Then with the For/Next. Every time I place an End If or Next, I receive errors.
Dim DateValue As Variant
DateValue = InputBox("Enter the date to copy")
'copy and paste column A to column A if E = input date
For Each Cell In Worksheets("Enrichment Report").Range("E:E")
If Cell.Value = DateValue Then
Sheets("Enrichment Report").Select
iMaxRow = 100
For iCol = 1 To 1
For iRow = 2 To iMaxRow
With Worksheets ("Enrichment Report").Cells(iRow, iCol)
If .Value = "" Then
'empty row, do nothing
Else
.Copy
Sheets("Intake Form").Select
Range (A" & Rows.Count).End(xlUp).Offset(1).Select
Activesheet.Paste
End If
End With
Next
End If
Next iRow
Next iCol
I think the following code will be much easier for you to follow
Also, it will be much faster looping through occupied cells with data in Column E, and not the entire column.
Code
Option Explicit
Sub Test()
Dim LastRow As Long, iMaxRow As Long, iCol As Long, iRow As Long
Dim DateValue As Variant
Dim Cell As Range
DateValue = InputBox("Enter the date to copy")
With Worksheets("Enrichment Report")
' get last row with data in column E
LastRow = .Cells(.Rows.Count, "E").End(xlUp).Row
'copy and paste column A to column A if E = input date
For Each Cell In .Range("E1:E" & LastRow)
If Cell.Value = DateValue Then
iMaxRow = 100
For iCol = 1 To 1
For iRow = 2 To iMaxRow
If .Cells(iRow, iCol).Value = "" Then
'empty row, do nothing
Else
.Cells(iRow, iCol).Copy
Sheets("Intake Form").Range("A" & Rows.Count).End(xlUp).Offset(1).PasteSpecial xlPasteAll
End If
Next iRow
Next iCol
End If
Next Cell
End With
End Sub
you could use AutoFilter() and avoid looping
also, use Application.InputBox() method instead of VBA InputBox() function to exploit its Type parameter and force a numeric input
Sub mmw()
Dim targetSht As Worksheet
Set targetSht = Sheets("Intake Form")
Dim DateValue As Variant
DateValue = Application.InputBox("Enter the date to copy", , , , , , , 2)
With Worksheets("Enrichment Report") ' reference your "source" sheet
With .Range("A1", .Cells(.Rows.Count, "E").End(xlUp)) ' reference its columns A:E cells from row 1 down to column E last not empty cell
.AutoFilter Field:=1, Criteria1:="<>" 'filter on referenced range 1st column with not empty cells
.AutoFilter Field:=5, Criteria1:=CStr(CDate(DateValue))
If Application.WorksheetFunction.Subtotal(103, .Cells) > 1 Then _
.Resize(.Rows.Count - 1).Offset(1).SpecialCells(xlCellTypeVisible).Copy _
Sheets("Intake Form").Cells(Sheets("Intake Form").Rows.Count, "A").End(xlUp).Offset(1) '<--| if any cell filtered other than headers (which get always filtered) then copy filtered values to "paste" sheet
End With
.AutoFilterMode = False
End With
End Sub
Obviously, with the proper indentation done by CallumDA, it should be written as below. Also there is a typo in the Range (A", it should be Range ("A":
For Each Cell In Worksheets("Enrichment Report").Range("E:E")
If Cell.Value = DateValue Then
Sheets("Enrichment Report").Select
iMaxRow = 100
For iCol = 1 To 1
For iRow = 2 To iMaxRow
With Worksheets ("Enrichment Report").Cells(iRow, iCol)
If .Value = "" Then
'empty row, do nothing
Else
.Copy
Sheets("Intake Form").Select
Range ("A" & Rows.Count).End(xlUp).Offset(1).Select
Activesheet.Paste
End If
End With
Next iRow
Next iCol
End If
Next
I have tried some of the codes suggested for similar macros.
I need the information in the cells in column L to be individually pasted as pictures in column M. I don't want to manually do this over and over for each of the hundreds of items.
Here is what it looks like without a loop or a repeat. Just doing the operation twice.
Sub pasteaspicture()
pasteaspicture Macro
Range("L3").Select
Selection.Copy
Range("M3").Select
ActiveSheet.Pictures.Paste.Select
Range("L4").Select
Application.CutCopyMode = False
Selection.Copy
Range("M4").Select
ActiveSheet.Pictures.Paste.Select
End Sub
Thanks.
This code should loop from row 3 to end of column L, if that is not what you want then I can edit it for you.
Application.screenupdating = False
With ActiveSheet
LastRow = .Cells(.Rows.Count, "L").End(xlUp).Row
End With
For i = 3 To LastRow
Range("L" & i).Copy
Range("M" & i).Select
ActiveSheet.Pictures.Paste.Select
Next i
Application.screenupdating = true
This code should work, but it includes a select, which is unwanted in VBA but since I have no clue how to use picture paste I used your code as a template.
Here is a quick (but long) way to do it without loops.
It sets ranges and finds the last row of the Column.
You will find Excel has many ways to skin the same nut. Hope this helps.
Sub CopyPic()
Dim lTopRow As Long
Dim lLeftColumn As Long
Dim lRightColumn As Long
Dim lLastRow As Long
With Sheets("Sheet1")
lTopRow = .Range("L3").Row
lLeftColumn = .Range("L3").Column
lLastRow = .Range("L:L").Find("*", , xlValues, , xlByRows, xlPrevious).Row
lRightColumn = lLeftColumn
Application.Goto .Range(Cells(lTopRow, lLeftColumn), Cells(lLastRow, lRightColumn)), scroll:=False
Selection.Copy
lLeftColumn = .Range("M3").Column
lRightColumn = lLeftColumn
Application.Goto .Range(Cells(lTopRow, lLeftColumn), Cells(lLastRow, lRightColumn)), scroll:=False
.Pictures.Paste.Select
End With
End Sub
I'm taking data that is listed across multiple columns and putting it into a single column (A). If there is data in column B, it grabs that data, sticks it at the end of the data in column A, then goes back and deletes the now empty column B, which moves all the other columns over one so now there is data in column B again, up until the point there are no more columns of data except for column A. The way I'm doing this currently is by listing multiple blocks of the same code below which is not efficient obviously and sooner or later the code will break. Any advice is appreciated!!
Range("B1").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Cut
Range("A1").Select
Selection.End(xlDown).Select
ActiveCell.Offset(1, 0).Range("A1").Select
ActiveSheet.Paste
Selection.End(xlUp).Select
ActiveCell.Offset(0, 1).Columns("A:A").EntireColumn.Select
Selection.Delete Shift:=xlToLeft
ActiveCell.Offset(0, -1).Range("A1").Select
I like Christmas007's answer. I wanted to share this solution too:
Sub MoveIt()
Dim mysht As Worksheet
Set mysht = ActiveSheet
Set myrng = mysht.UsedRange
nextrow = mysht.Cells(mysht.Rows.Count, 1).End(xlUp).Row
For i = 2 To myrng.Columns.Count
lastColrow = myrng.Cells(mysht.Rows.Count, i).End(xlUp).Row
If lastColrow <> 1 Or myrng.Cells(1, i) <> "" Then
For j = 1 To lastColrow
nextrow = nextrow + 1
mysht.Cells(nextrow, 1) = myrng.Cells(j, i)
Next j
End If
Next i
Range(myrng.Columns(2), myrng.Columns(myrng.Columns.Count)).Clear
End Sub
I like it because it doesn't use the copy, paste, and delete functions. In my experience these functions start to cause the macro to drag if you are dealing with big workbooks and they also require that the sheet is activated.
There is a pretty simple way to do this:
Sub MoveIt()
Dim LastRow As Long
Dim ws1 as Worksheet
Set ws1 = Sheets("Name of Sheet")
Do While (ws1.Range("B1").Value <> "")
LastRow = ws1.Range("A" & ws1.Rows.Count).End(xlUp).Row + 1
ws1.Range("B1:B" & ws1.Range("B" & ws1.Rows.Count).End(xlUp).Row).Copy
ws1.Range("A" & LastRow).PasteSpecial
ws1.Range("B1").EntireColumn.Delete xlToLeft
Loop
End Sub
I put together a macro that will search through a column in a table I have and ONLY copy-paste the rows of that table which have a numerical value in that column onto the next sheet of the spreadsheet. This happens once a button is pressed. My code is as follows:
Sub Button1_Click()
Dim r As Long, endRow As Long, pasteRowIndex As Long
Set WS = Worksheets("Sheet1")
With WS
Set LastCell = .Cells(.Rows.Count, "C").End(xlUp)
LastCellRowNumber = LastCell.Row
End With
'endRow = 20 of course it's best to retrieve the last used row number via a function
pasteRowIndex = 1
For r = 2 To LastCellRowNumber 'Loop through sheet1 and search for your criteria
If IsNumeric(Cells(r, Columns("E").Column).Value) And Not IsEmpty(Cells(r, Columns("E").Column).Value) Then 'Found
'Copy the current row
Rows(r).Select
Selection.Copy
'Switch to the sheet where you want to paste it & paste
Sheets("Sheet2").Select
Rows(pasteRowIndex).Select
ActiveSheet.Paste
'Next time you find a match, it will be pasted in a new row
pasteRowIndex = pasteRowIndex + 1
'Switch back to your table & continue to search for your criteria
Sheets("Sheet1").Select
End If
Next r
End Sub
This works but my problem with it is that it copies the rows with their formulas (which become unusable once copied), so I needed some sort of paste special to only copy the values. I tried this but either keep getting errors or it doesn't work the same way.. can someone please check it for me and point me in the right direction?
Sub Button1_Click()
Dim r As Long, endRow As Long, pasteRowIndex As Long, Location As Long
Set WS = Worksheets("Sheet1")
With WS
Set LastCell = .Cells(.Rows.Count, "C").End(xlUp)
LastCellRowNumber = LastCell.Row
End With
pasteRowIndex = 1
For r = 2 To LastCellRowNumber 'Loop through sheet1 and search for your criteria
If IsNumeric(Cells(r, Columns("E").Column).Value) And Not IsEmpty(Cells(r, Columns("E").Column).Value) Then 'Found
Location = 1
'Copy the current row
Rows(r).Select
Selection.Copy
'Switch to the sheet where you want to paste it & paste
Sheets("Sheet2").Select
Rows(pasteRowIndex).Select
ActiveSheet.Range(Cells(Location, 1)).PasteSpecial xlPasteValues
Application.CutCopyMode = False
'Next time you find a match, it will be pasted in a new row
pasteRowIndex = pasteRowIndex + 1
Location = Location + 1
'Switch back to your table & continue to search for your criteria
Sheets("Sheet1").Select
End If
Next r
End Sub
Thank you so much!
ActiveSheet.Range(Cells(Location, 1)).PasteSpecial xlPasteValues
You cannot nest Cells (singly) within Range - Cells is already a Range:
ActiveSheet.Cells(Location, 1).PasteSpecial xlPasteValues