I have a column in sheet 1 containing different values. I'd like to loop thru the column and create new sheets with the sheet name corresponding to the values. Each time I create a sheet, I like to set the new sheet active and do some task on that sheet.
Sub test()
i = 4 'starting row in sheet 1
While Not IsEmpty(Cells(i, 1))
Dim ws As Worksheet
Set ws = ThisWorkbook.Sheets.Add
ws.Name = Cells(i, 1).Value
'do something to new sheet
i = i + 1
Wend
End Sub
This does not work and the examples I've found online are way too complex for my need. I hope for an easy solution pointing out what I did wrong. thanks
This adds worksheets and names them as per the values in A4 downwards:
Dim wks As Worksheet
Dim wksNew As Worksheet
Dim rngCell As Range
Set wks = Sheets("Sheet1")
Set rngCell = wks.Range("A4")
While Not IsEmpty(rngCell)
Set wksNew = ActiveWorkbook.Worksheets.Add(After:=Sheets(Sheets.Count))
wksNew.Name = rngCell.Value
'do stuff with wksNew
Set rngCell = rngCell.Offset(1)
Wend
Related
I have been running into some issues trying to use VBA to compare 2 tables in different worksheets, and then copy any rows in the "Master" sheet that are not found in the "New" sheet. Both tables are formatted as tables. The match is based on an "ID" column in Column A of both tables. If an ID is in the "Master" sheet, but not in the "New" sheet, than that entire row should be copy and pasted to the end of the table in the "New" sheet.
I updated some code found in another forum, which is almost working. However, it only seems to paste over the ID data into Column A, and not the entire corresponding row of data which is needed.
Sub compare()
Dim i As Long
Dim lrs As Long
Dim lrd As Long
With Worksheets("Master")
lrs = .Cells(.Rows.Count, 1).End(xlUp).Row
For i = 2 To lrs 'assumes header in row 1
If Application.IfError(Application.Match(.Cells(i, 1), Worksheets("New").Columns(1), 0), 0) = 0 Then
lrd = Worksheets("New").Cells(Worksheets("test").Rows.Count, 1).End(xlUp).Row
Worksheets("New").Cells(lrd + 1, 1).Value = .Cells(i, 1).Value
End If
Next i
End With
End Sub
I think the issue has to do with the "Cells" reference, instead of a range, but I do not know how to make that line dynamic.
Slightly different approach, but you need to use something like Resize() to capture the whole row, and not just the cell in Col A.
Sub compare()
Const NUM_COLS As Long = 10 'for example
Dim wb As Workbook, wsSrc As Worksheet, wsDest As Worksheet
Dim c As Range, cDest As Range
Set wb = ThisWorkbook 'or ActiveWorkbook for example
Set wsSrc = wb.Worksheets("Master")
Set wsDest = wb.Worksheets("New")
Set cDest = wsDest.Cells(Rows.Count, 1).End(xlUp).Offset(1) 'next empty row
For Each c In wsSrc.Range("A2:A" & wsSrc.Cells(Rows.Count, 1).End(xlUp).Row).Cells
If IsError(Application.Match(c.Value, wsDest.Columns(1), 0)) Then
cDest.Resize(1, NUM_COLS).Value = c.Resize(1, NUM_COLS).Value
Set cDest = cDest.Offset(1) 'next row
End If
Next c
End Sub
I am trying to create a consolidated list of highlighted cells that are on different tabs in my workbook. As I understand VBA is my best option.
Logic would be something like:
Loop through all tabs and
If cell = color index 4 then
copy value and paste into a tab called 'highlightedcells'
Im as far as this currently
sub findhighlights
For Each ws In ActiveWorkbook.Worksheets
For Each Cell In ws.UsedRange.Cells
If Cell.Interior.ColorIndex = 4 Then
cell.value.copy
Any help would be welcomed.
Try this out:
Sub findhighlights()
Dim wb As Workbook, ws As Worksheet, c As Range, wsList As Worksheet
Set wb = ActiveWorkbook 'always use a specific workbook
Set wsList = wb.Worksheets("Listing") 'listing goes here
For Each ws In wb.Worksheets 'loop sheets
If ws.Name <> wsList.Name Then 'skip the "Listing" sheet
For Each c In ws.UsedRange.Cells
If c.Interior.ColorIndex = 4 Then
'list info for this cell
With wsList.Cells(Rows.Count, "A").End(xlUp).Offset(1)
.Resize(1, 3).Value = Array(ws.Name, c.Address, c.Value)
End With
End If
Next c
End If 'is not the Listing sheet
Next ws
End Sub
I am trying to select rows in a table based on the word "Yes" being present in column J.
I have a table going from column A to J, and I want to select the rows where there is a "Yes" in column J and paste only those rows into a new sheet.
Once selected, I need to copy these rows to a new sheet or word document.
I have tried a range of forumulas, this is for Windows MS Excel software, using a VBA Macro.
I am using the following VBA, but having issues:
Sub Macro1()
Dim rngJ As Range
Dim cell As Range
Set rngJ = Range("J1", Range("J65536").End(xlUp))
Set wsNew = ThisWorkbook.Worksheets.Add
For Each cell In rngJ
If cell.Value = "Yes" Then
cell.EntireRow.Copy
wsNew.Sheets("Sheet1").Range("J65536").End(xlUp).Offset(1, 0).Select
ActiveSheet.Paste
End If
Next cell
End Sub
Any help would be very much appreciated!
Rather than finding, copying and pasting for each cell, why not find all, then copy and paste once like this:
Sub Macro1()
Dim rngJ As Range
Dim MySel As Range
Set rngJ = Range("J1", Range("J" & Rows.Count).End(xlUp))
Set wsNew = ThisWorkbook.Worksheets.Add
For Each cell In rngJ
If cell.Value = "Yes" Then
If MySel Is Nothing Then
Set MySel = cell.EntireRow
Else
Set MySel = Union(MySel, cell.EntireRow)
End If
End If
Next cell
If Not MySel Is Nothing Then MySel.Copy Destination:= wsNew.Range("A1")
End Sub
It's better to avoid using Select as much as possible; see this link.
Use something like this
Option Explicit
Public Sub CopyYesRowsToNewWorksheet()
Dim wsSource As Worksheet
Set wsSource = ThisWorkbook.ActiveSheet 'better define sheet by name ThisWorkbook.Worksheets("SourceSheet")
Dim DataRangeJ As Variant 'read "yes" data into array for faster access
DataRangeJ = wsSource.Range("J1", wsSource.Range("J" & wsSource.Rows.Count).End(xlUp)).Value
Dim wsNew As Worksheet
Set wsNew = ThisWorkbook.Worksheets.Add
Dim NextFreeRow As Long
NextFreeRow = 1 'start pasting in this row in the new sheet
If IsArray(DataRangeJ) Then
Dim iRow As Long
For iRow = LBound(DataRangeJ) To UBound(DataRangeJ) 'loop through data array
If DataRangeJ(iRow, 1) = "yes" Then
wsNew.Rows(NextFreeRow).Value = wsSource.Rows(iRow).Value 'copy the values of the row
NextFreeRow = NextFreeRow + 1
End If
Next iRow
ElseIf DataRangeJ = "yes" Then 'if only the first row has data
wsNew.Rows(NextFreeRow).Value = wsSource.Rows(1).Value
End If
End Sub
The line
wsNew.Rows(NextFreeRow).Value = wsSource.Rows(iRow).Value
only copys the value without formatting. If you also want to copy the formatting replace it with
wsSource.Rows(iRow).Copy Destination:=wsNew.Rows(NextFreeRow)
In the MasterSheet say I have column headers "Employee Names", "CarType" and "DOB". These columns and their row data are found in different sheets in the same workbook. I need a simple lookup function in VBA to search for multiple column headers and COPY over the entire column. I need multiple columns in the master file to be filled in like this so a loop function is needed.
If a heading is not found leave the row blank and move on to the column header on the MasterSheet.
Thank you in advance! My first post and so I don't know if the explanation above helps.
Sample MasterSheet
Sheet2 where one column head is
The below basic code is what I found but it's too basic and doesn't loop through
Macro VBA to Copy Column based on Header and Paste into another Sheet
This is what I have so far but the limitations are that it looks at one sheet at a time and the header search is not dynamic.
Sub MasterSheet()
Dim newSht As Worksheet, sSht As Worksheet, Hdrs As Variant, i As Long, EdrisRange As
Range
Set sSht = ActiveSheet
'Expand the array below to include all relevant column headers - I want the below
line to be dynamic. Looking at multiple headers from the MasterSheet.
Hdrs = Array("Heading 1")
Application.ScreenUpdating = False
Set newSht = Worksheets.Add(after:=sSht)
With sSht.UsedRange.Rows(1)
For i = LBound(Hdrs) To UBound(Hdrs)
Set EdrisRange = .Find(Hdrs(i), lookat:=xlWhole)
If Not EdrisRange Is Nothing Then
Intersect(EdrisRange.EntireColumn, sSht.UsedRange).Copy
Destination:=newSht.Cells(1, i + 1)
End If
Next i
Application.CutCopyMode = False
End With
Application.ScreenUpdating = True
End Sub
Something like this should work:
Sub MasterSheet()
Dim wb As Workbook
Dim newSht As Worksheet, Hdrs As Variant, i As Long, EdrisRange As Range
Hdrs = Array("Heading 1", "Heading 2")
Set wb = ActiveWorkbook
Set newSht = wb.Worksheets.Add(after:=ActiveSheet)
For i = LBound(Hdrs) To UBound(Hdrs)
Set EdrisRange = FindHeaderInWorkbook(wb, CStr(Hdrs(i)), newSht)
If Not EdrisRange Is Nothing Then
Application.Intersect(EdrisRange.EntireColumn, EdrisRange.Parent.UsedRange).Copy _
Destination:=newSht.Cells(1, i + 1)
End If
Next i
Application.CutCopyMode = False
End Sub
'find a header *HeaderText* in a workbook *wb*, excluding the sheet *excludeSheet*
Function FindHeaderInWorkbook(wb As Workbook, HeaderText As String, excludeSheet As Worksheet)
Dim sht As Worksheet, rng As Range
For Each sht In wb.Worksheets
If sht.Name <> excludeSheet.Name Then
Set rng = sht.Rows(1).Find(what:=HeaderText, lookat:=xlWhole)
If Not rng Is Nothing Then Exit For
End If
Next sht
Set FindHeaderInWorkbook = rng
End Function
Hi I'm looking to create code for copying certain columns (AH to AX) across all worksheets then skipping worksheets named "Aggregated" & "Collated Results"
I have this already
Sub FillSheets()
Dim ws As Worksheets
Dim worksheetsToSkip As Variant
Dim rng As Range
Dim sh As Sheet1
Set rng = sh.Range("AH1:AX7200")
worksheetsToSkip = Array("Aggregated", "Collated Results")
For Each ws In Worksheets
If IsError(Application.Match(ws.Name, worksheetsToSkip, 0)) Then
End Sub
This will
Loop through sheets
"Copy" data from AH1 - AX1 down to the last used row that is determined by Column AH (Update column if needed)
"Paste" data on a sheet named Sheet1 (Update if needed). The data will be pasted in Column AH on the first available blank row. It's not clear what column you want to paste the data in. You just need to change AH to Some Column to modify
"Copy" and "Paste" are in quotes because we are really just transferring values here since this is quicker. We are actually setting the values of two equal sized ranges equal to each other.
Option Explicit
Sub AH_AX()
'Update "Sheet1" to sheet where data is being pasted
Dim ms As Worksheet: Set ms = ThisWorkbook.Sheets("Sheet1")
Dim ws As Worksheet, wsLR As Long, msLR As Long
Dim CopyRange As Range, PasteRange As Range
For Each ws In Worksheets
If ws.Name <> "Aggregated" And ws.Name <> "Collated Results" Then
'Determine last rows
wsLR = ws.Range("AH" & ws.Rows.Count).End(xlUp).Row
msLR = ms.Range("AH" & ms.Rows.Count).End(xlUp).Offset(1).Row
'Set Ranges
Set CopyRange = ws.Range("AH1:AX" & LR)
Set PasteRange = ms.Range("AH" & msLR).Resize(CopyRange.Rows.Count, CopyRange.Columns.Count)
'Value Transfer (Quicker than copy/paste)
PasteRange.Value = CopyRange.Value
End If
Next ws
End Sub