I'm still new to VBA and I'm a bit lost on how to solve this particular issue.
I have several worksheets within 1 workbook. The goal is to copy data from each worksheet based on the column headings, since not all of the column headings are uniform across all sheets.
For ex:
The Master Sheet has 6 column headings which I'd like to pull.
Sheet 1 has 8 column headings, the values for some columns within this are blank.
Sheet 2 has 7 column headings.
Sheet 3 has 10 column headings, etc.
My goal is to go to each sheet, have it loop through each column heading and copy/paste the data into the Master sheet if the column heading matches.
I don't know how to get it to look for the last row and copy the whole column based on the heading.
An example of code I've pieced together below:
Sub MasterCombine()
Worksheets("Master").Activate
Dim ws As Worksheet
Set TH = Range("A1:F1")
For Each ws In ActiveWorkbook.Worksheets
If ws.Name <> "Master" And ws.Range("A8").Value <> "" Then
ws.Select
Range("A8").Select
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
Worksheets("Master").Activate
For Each cell In TH
If cell.Value = "Subject" Then
cell.EntireColumn.Copy
End If
The problem with the above is that it copies the entire range but doesn't filter out column headings that aren't in the Master sheet.
Any help would be appreciated.
This might work. Loading your Master headers into an array. Then looping through each ws - then looping through your headers array.
Option Explicit
Sub MasterMine()
Dim Master As Worksheet: Set Master = ThisWorkbook.Sheets("Master")
Dim LR1 As Long, LR2 As Long, LC1 As Long, LC2 As Long
Dim ws As Worksheet, Found As Range, i As Long, Arr
LC1 = Master.Cells(1, Master.Columns.Count).End(xlToLeft).Column
Arr = Master.Range(Master.Cells(1, 1), Master.Cells(1, LC1)).Value
For Each ws In Worksheets
For i = LBound(Arr) To UBound(Arr)
LC2 = ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column
Set Found = ws.Range(ws.Cells(1, 1), ws.Cells(1, LC2)).Find(Arr(i, 1), LookIn:=xlWhole)
If Not Found Is Nothing Then
LR1 = Master.Cells(Master.Rows.Count, i).End(xlUp).Offset(1).Row
LR2 = ws.Cells(ws.Rows.Count, Found.Column).End(xlUp).Row
ws.Range(ws.Cells(2, Found.Column), ws.Cells(LR2, Found.Column)).Copy
Master.Cells(LR1, i).PasteSpecial xlPasteValues
End If
Next i
Next ws
End Sub
Related
I have 5 columns of data. The data is grouped by employee name and number (cols A-B) and their respective pay types (col C). I need to
Copy employee name to blank cell below in col A
Copy employee number to blank cell below in col B
Add the word "Advance" in the blank cell in col C
Current code selects all blank cells in cols A-E and fills with the values from above:
Sub FillBlanksValueAbove1()
Dim sName As String
sName = ActiveSheet.Name
Dim ws As Worksheet
Dim lastRow As Long, lastCol As Long
Dim rng As Range
'Set variable ws Active Sheet name
Set ws = Sheets(sName)
With ws
'Get the last row and last column
lastRow = .Range("A" & .Rows.Count).End(xlUp).Row
lastCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
'Set the range
Set rng = .Range(.Cells(1, 1), .Cells(lastRow, lastCol))
rng.Select
'Select Blanks
rng.SpecialCells(xlCellTypeBlanks).Select
'Fill Blanks with value above
Selection.FormulaR1C1 = "=R[-1]C"
'Paste Formulas as Values
rng.Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:= _
xlNone, SkipBlanks:=False, Transpose:=False
End With
End Sub
This is what the spreadsheet looks like now:
This is what I need it to look like:
This is the end result I currently get:
Thank you so so much!
Test the next code, please. No need of any selection, a little simplified:
Sub FillBlanksValueAbove1()
Dim rng As Range, rngVis As Range
Dim ws As Worksheet, lastRow As Long
'Set variable ws Active Sheet name
Set ws = ActiveSheet
With ws
'Get the last row
lastRow = .Range("A" & .Rows.count).End(xlUp).Row
'Set the range
Set rng = .Range(.cells(1, 1), .cells(lastRow, 2)) 'Col B:C
Set rngVis = rng.SpecialCells(xlCellTypeBlanks)
'Fill ADVANCE in column C:C
rngVis.Offset(, 1).Value = "ADVANCE"
'Fill Blanks with value above
rngVis.FormulaR1C1 = "=R[-1]C"
'Paste Formulas as Values
rngVis.Value = rngVis.Value
End With
End Sub
I have three sheets in a workbook and I want to copy all the rows from all the first three sheets into sheet 4 which has the column 'C' marked as Y.
I'm answering this question, because I'm bored.
The code below assigns the worksheets to filter to an array, loops thru the array, filters the range, then copies the visible cells in the filter data. If "A1" is empty; it will paste the copied data from each worksheet to Range("A1"), else it will paste the data to the first empty cell in "column A". Change the worksheet names as required.
Sub FltrPste()
Dim wb As Workbook, shtArr As Variant, wsDest As Worksheet, i As Long, lRow4 As Long
Set wb = ThisWorkbook
shtArr = Array("Sheet1", "Sheet2", "Sheet3")
Set wsDest = wb.Sheets("Sheet4")
lRow = wsDest.Range("A" & Rows.Count).End(xlUp).Row
For i = LBound(shtArr) To UBound(shtArr)
With wb.Sheets(shtArr(i)).Range("A1").CurrentRegion
.AutoFilter
.AutoFilter Field:=3, Criteria1:="y"
.Offset(1).Resize(.Rows.Count - 1).SpecialCells(xlCellTypeVisible).EntireRow.Copy
If Range("A1") = "" Then
wsDest.Cells(1, 1).PasteSpecial xlPasteValues
Else
wsDest.Cells(Rows.Count, "A").End(xlUp).Offset(1).PasteSpecial xlPasteValues
End If
.AutoFilter
End With
Next i
End Sub
I'm having trouble getting a copied row to paste into a different worksheet, on the first available row.
Problem is I need the data to paste into column B but my macro pastes into other columns. Column A has a Vlookup formula and columns B-E have specific drop-downs which excel sees as non-empty cells.
I don't know if this is causing the problem?
My code;
Dim iRow As Integer
Dim ws As Worksheet
Set ws = Worksheets("Dispute_Details")
ws.Activate
On Error Resume Next
iRow = Range("F:F").Find(What:=" ", SearchOrder:=xlRows, SearchDirection:=xlPrevious, LookIn:=xlValues).Row + 1
Sheets(ws).Range("b", iRow).Activate
Worksheets("Dispute_Details").Paste
Application.CutCopyMode = False}
Dim iRow As Long
With Worksheets("Dispute_Details")
iRow = .Cells(.Rows.Count, 5).End(xlUp).Row + 1
.Range("B" & iRow).PasteSpecial Paste:=xlPasteAll
Application.CutCopyMode = False
End With
I want to copy all rows below Row 3 in sheet2 and paste them below the last row in sheet 1. I don't want to use 'Activesheet" like I have below. Is there another way to accomplish this?
(This doesn't work):
Rows("3:3").Select
Range(Selection, Selection.End(x1Down)).Select
Selection.Copy
Sheets("sheet1").Select
Range(Selection, Selection.End(x1Down)).Select
ActiveSheet.Paste
Dim ws as Worksheet
Set ws = Worksheets("mySheet") 'change name as needed
With ws
'assumes data is in a "table" format with all data rows in column A and data columns in row 1
Dim lRow as Long, lCol as Long
lRow = .Range("A" & .Rows.Count).End(xlUp).Row
lCol = .Cells(1,.Columns.Count).End(xlToLeft).Column
.Range(.Range("A4"),.Cells(lRow,lCol)).Copy _
Worksheets("Sheet1").Range("A" & .Rows.Count).End(xlUp).Offset(1)
End With
I have an Excel workbook with two sheets: sheet1 has a large table of data in columns A to R, headers at row 1. Sheet2 has data in columns A to AO.
Using VBA I am trying to copy rows from sheet1 and paste them to the end of sheet2. Also I need to copy only columns A to R, not the entire row.
In other words, cells A2:R2 from sheet1 need to be copied to first AND second row that don't have data in column A.
I have the following code that copies the required cells from sheet1, but I cannot figure out how to copy every row twice:
Sub example()
For Each ce In Range("A2:A" & Cells(Rows.Count, 1).End(xlUp).Row)
If Not IsEmpty(ce) Then
Sheets("sheet2").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Resize(1, 18).Value = Range(ce, ce.Offset(0, 17)).Value
End If
Next ce
End Sub
Try this:
Option Explicit
Sub CopyRows()
Dim ws1 As Worksheet, ws2 As Worksheet
Dim i As Integer, k As Integer
Dim ws1LR As Long, ws2LR As Long
Set ws1 = Sheets("Sheet1")
Set ws2 = Sheets("Sheet2")
ws1LR = ws1.Range("A" & Rows.Count).End(xlUp).Row + 1
ws2LR = ws2.Range("A" & Rows.Count).End(xlUp).Row + 1
i = 2
k = ws2LR
Do Until i = ws1LR
With ws1
.Range(.Cells(i, 1), .Cells(i, 18)).Copy
End With
With ws2
.Cells(k, 1).PasteSpecial
.Cells(k, 1).Offset(1, 0).PasteSpecial
End With
k = k + 2
i = i + 1
Loop
End Sub
Change Sheet1 and Sheet2 if they are called different things in your workbook.