I have a sheet I'm trying to have populate names and some cell values from the following sheets.
I'm trying to copy the values from the specified cells, dump them into my sheet, and move to the next sheet.
Here is a snapshot of the sheet I'm trying to build, and I've written in the cell location of each value I'm looking for.
The script would take the values in those specified cells on each following sheets and then move to the next.
Sub EfficiencyReport001()
Dim ws As Worksheet, rep As Worksheet, LastRow As Double
With ThisWorkbook
For n = 1 To Sheets.Count
Set ws = Worksheets(n)
Set rep = Worksheets("001 Efficiency Report")
LastRow = rep.Range("A3", rep.Range("A3").End(xlDown)).Rows.Count
If IsNumeric(ws.Name) Then
If rep.Range("A3") = "" Then
ws.Range("E20", ws.Range("E20").End(xlDown)).Copy _
Destination:=rep.Range("A3")
Else:
ws.Range("E20", ws.Range("E20").End(xlDown)).Copy _
Destination:=rep.Range("A" & LastRow)
End If
End If
Next n
End With
End Sub
I think you want something like this.
Loop through all sheets (except the Rep sheet)
Copy values from E20 do Last Cell on your current loop sheet
Paste the values on Rep sheet in the first available cell in Column A
Sub Shelter_In_Place()
Dim rep As Worksheet: Set rep = ThisWorkbook.Sheets("001 Efficiency Report")
Dim ws As Worksheet
Dim lr As Long
For Each ws In Worksheets
If ws.Name <> rep.Name Then
lr = rep.Range("A" & ws.Rows.Count).End(xlUp).Offset(1).Row
ws.Range("E20:E" & ws.Range("E" & ws.Rows.Count).End(xlUp).Row).Copy
rep.Range("A" & lr).PasteSpecial xlPasteValues
End If
Next ws
End Sub
If you just want to grab the 4 individual cells from each sheet then you can use
Sub Shelter_In_Place()
Dim rep As Worksheet: Set rep = ThisWorkbook.Sheets("001 Efficiency Report")
Dim ws As Worksheet
Dim lr As Long
For Each ws In Worksheets
If ws.Name <> rep.Name Then
lr = rep.Range("A" & ws.Rows.Count).End(xlUp).Offset(1).Row
rep.Range("A" & lr).Value = ws.Range("E20").Value
rep.Range("B" & lr).Value = ws.Range("AD65").Value
rep.Range("C" & lr).Value = ws.Range("AF65").Value
rep.Range("D" & lr).Value = ws.Range("AH65").Value
rep.Range("E" & lr).Value = ws.Range("AJ65").Value
End If
Next ws
End Sub
Related
I wan't to transfer data within a range from each worksheet of a workbook excluding specific worksheet names based on a value being greater than zero within a range. Based on the value being greater than zero I wan't to transfer corresponding column values in the same row and update the database sheet by putting the values under specific columns from all worksheets apart from specific sheet and populate the list in the database sheet. My code does not seem to be working.
Sub Button4_Click()
Dim sourceRng As Range
Dim cell As Range
Dim i As Long
Dim ws As Worksheet
Dim wsC As Worksheet
Set wsC = Sheets("Database")
For Each wkSht In ThisWorkbook.Worksheets
If ws.Name <> "Database" And ws.Name <> "Combine" And ws.Name <> "CETIN" Then
Set sourceRng = ActiveSheet.Range("AY17:AY30")
i = 1
For Each cell In sourceRng
If cell.Value > 0 Then
cell.Resize(1, 1).Copy Destination:=wsD.Range("A" & i)
i = i + 1
End If
Next cell
End If
Next
End Sub
I believe this should work for you. Your image is hard to read, so you may need to adjust the columns if I read them wrong.
Option Explicit
Sub Button4_Click()
Dim i As Long
Dim wkSht As Worksheet
Dim wsC As Worksheet
Dim rowCount As Integer
Dim nextEmptyRow As Integer
Set wsC = ThisWorkbook.Worksheets("Database")
For Each wkSht In ThisWorkbook.Worksheets
nextEmptyRow = wsC.Cells(Rows.Count, "A").End(xlUp).Row + 1
If wkSht.Name <> "Database" And wkSht.Name <> "Combine" And wkSht.Name <> "CETIN" Then
For i = 17 To 30
If wkSht.Range("AY" & i).Value > 0 Then
wkSht.Range("AY" & i).Copy Destination:=wsC.Range("A" & nextEmptyRow)
wkSht.Range("K" & i).Copy Destination:=wsC.Range("B" & nextEmptyRow)
wkSht.Range("R" & i).Copy Destination:=wsC.Range("C" & nextEmptyRow)
wkSht.Range("T" & i).Copy Destination:=wsC.Range("D" & nextEmptyRow)
End If
Next i
End If
Next wkSht
End Sub
You can also replace wkSht.Range("AY" & i).Copy Destination:=wsC.Range("A" & nextEmptyRow) with wsC.Range("A" & nextEmptyRow).value = wkSht.Range("AY" & i).value for those 4 lines if you only want to preserve the value and not formatting.
I've created several macro buttons on worksheet 5, this works if I'm on worksheet 1 but when I try to click the button for this macro on worksheet 5 it doesn't work. What do I need to add to make it select worksheet 1 if I'm on another worksheet in the same workbook?
Sub Delete_External ()
'
' Delete_External Macro
Dim LastRow As Long
Dim i As Long
LastRow = Range("K1000").End(xlUp).Row
For i = LastRow To 1 Step -1
If Range("K" & i) = "External" Then
Range("K" & i).EntireRow.Delete
End If
Next
End Sub
Qualify your objects with a worksheet.
Sub Delete_External ()
'
' Delete_External Macro
Dim ws as Worksheet: Set ws = ThisWorkbook.Sheets("Sheet1")
Dim LastRow As Long
Dim i As Long
LastRow = ws.Range("K1000").End(xlUp).Row
For i = LastRow To 1 Step -1
If ws.Range("K" & i) = "External" Then
ws.Range("K" & i).EntireRow.Delete
End If
Next
End Sub
I would avoid deleting rows inside your loop as this can become time consuming depending on the data set and amount of criteria matches. Consider this alternative that loops through your range and creates a collection (Union) of cells that match your criteria. Once the loop is complete, delete the Union all at once.
This has also been updated to a more common last row finder methodology and removes the backwards loop since this method does not require it!
Sub Delete_External()
'
' Delete_External Macro
Dim ws As Worksheet: Set ws = ThisWorkbook.Sheets("Sheet1")
Dim LR As Long, i As Long
Dim DeleteMe As Range
LR = ws.Range("K" & ws.Rows.Count).End(xlUp).Row
For i = 2 To LR
If ws.Range("K" & i) = "External" Then
If Not DeleteMe Is Nothing Then
Set DeleteMe = Union(DeleteMe, ws.Range("K" & i))
Else
Set DeleteMe = ws.Range("K" & i)
End If
End If
Next i
If Not DeleteMe Is Nothing Then
DeleteMe.EntireRow.Delete
End If
End Sub
I am trying to create code (Loop) so that when a task is allocated to a team member (in a cell in column H) the code searches the cell value with the existing sheet names and if there is a match, the sheet then makes the task member sheet active sheet, finds the last available line and adds the allocated tasks to the sheet. The code should run for all filled cells in the column.
However, the code i have currently written bugs out. I am finding it hard to define the worksheetname (Cell value) etc.
Sub TaskAllocation()
Dim cell As Range, Lastrow1 As Double, i As Integer
Dim SubTaskWs As Worksheet, Ws As Worksheet, Lastrow2 As Double
Set SubTaskWs = ActiveWorkbook.Worksheets("Sub tasks")
Set Ws = ActiveWorkbook.Sheets(WsName)
i = o
Lastrow1 = SubTaskWs.Range("H" & Rows.Count).End(xlUp).Row
Lastrow2 = Ws.Range("A" & Rows.Count).End(xlUp).Row
For Each cell In SubTaskWs.Range("H4:H" & Lastrow1)
For Each Ws In Sheets
If cell.value = Ws.Name Then
Ws.Range("A" + (Lastrow2 + (i))).EntireRow.Insert
Call copyFormattingAbove(Ws, "A" & Lastrow2)
Ws.Range(("A" & Lastrow2) + (i)).value = cell.Offset(, -6)
Ws.Range(("B" & Lastrow2) + (i)).value = cell.Offset(, -5)
i = i + 1
End If
Next Ws
Next cell
End Sub
I did change a bit your code to make it more readable.
Some tips for the future:
Use the Option Explicit on the top of your moduel to fource the declaration of all your variables.
Always try to declare your variables close to where they are used.
Never declare a integervariable, use Long instead. Don't use Double for rows either, Double and Single are for floating numbers.
Here is the code:
Option Explicit
Sub TaskAllocation()
Dim cell As Range
Dim SubTaskWs As Worksheet
Set SubTaskWs = ActiveWorkbook.Worksheets("Sub tasks")
Dim Lastrow1 As Long
Lastrow1 = SubTaskWs.Range("H" & Rows.Count).End(xlUp).Row
Dim ws As Worksheet
Dim cell As Range
Dim Lastrow2 As Long, i As Long
i = 0
Dim Tasks As Object
FillTasks Tasks
For Each cell In SubTaskWs.Range("H4:H" & Lastrow1) 'change this range and loop through the column with the tasks
If Tasks.Exists(cell) Then GoTo AlreadyDone
For Each ws In Sheets
If SubTaskWs.Cells(cell.Row, "H") = ws.Name Then
Lastrow2 = ws.Range("A" & Rows.Count).End(xlUp).Row + 1
copyFormattingAbove ws, "A" & Lastrow2
ws.Range("A" & Lastrow2).Value = SubTaskWs.Cells(cell.Row, 2)
ws.Range("B" & Lastrow2).Value = SubTaskWs.Cells(cell.Row, 3)
End If
Next ws
AlreadyDone:
Next cell
End Sub
Function FillTasks(Tasks As Object)
Set Tasks = CreateObject("Scripting.Dictionary")
Dim ws As Worksheet
For Each ws In ThisWorkbook.Worksheets 'loop through sheets
If Not ws.Name = "Sub tasks" Then
'code to find the right columnd and loop through the existing tasks
'there is no need for an item on this case, you only need to know if it exists
If Not Tasks.Exists(cell) Then Tasks.Add cell, 1
End If
Next ws
End Function
I am trying to paste values from a bunch of tables into one long list. I have the tables spread across different sheets and the number of rows changes, but the columns do not. Then I am also trying to paste a string value that tells what sheet it came from, but having trouble with the active cell part of the code.
When I first tried it, it did not compile, hence why I came here, to figure out why it did not compile. Going back and forth with urdearboy, below, I was able to get the correct code working here.
I have the following:
sub copypaste()
Dim ws1 as worksheet
dim ws2 as worksheet
dim mas as worksheet
Set ws1 =ThisWorkbook.Sheets("Sheet1")
Set ws2=ThisWorkbook.Sheets("Sheet2")
Set mas=ThisWorkbook.Sheets("Master") 'where I create my list
For Each ws In Worksheets
If ws.Name <> mas.Name Then
LRow = mas.Range("A" & mas.Rows.Count).End(xlUp).Offset(1, 0).Row
wsLRow = ws.Range("A" & ws.Rows.Count).End(xlUp).Row
ws.Range("A2:A" & wsLRow - 1).Copy
mas.Range("A" & LRow).PasteSpecial Paste:=xlPasteValues
ws.Range("B2:B" & wsLRow - 1).Copy
mas.Range("B" & LRow).PasteSpecial Paste:=xlPasteValues
mas.Range(mas.Cells(LRow, 4), mas.Cells(wsLRow + LRow - 2, 4)) = ws.Name 'I need my sheet value in the fourth column, not the third, but simply change the col coordinate in the Cells equation above
End If
Next ws
'In order to figure out the sheet name, I used the following:
Dim rng As Range
Set rng = mas.Range("D2", Range("D2").End(xlDown))
For Each Cell In rng
If Cell.Value = "Sheet 1" Then
Cell.Value = "S1"
ElseIf Cell.Value = "Sheet 2" Then
Cell.Value = "S2"
End If
Next Cell
end sub
This will loop through all sheets, with the exception of Master, and import the values on Column A to Master accompanied by the origin of the data (sheet name).
Option Explicit for good measure.
Option Explicit
Sub copypaste()
Dim mas As Worksheet: Set mas = ThisWorkbook.Sheets("Master")
Dim ws As Worksheet, LRow As Long, wsLRow As Long
Application.ScreenUpdating = False
For Each ws In Worksheets
If ws.Name <> mas.Name Then
LRow = mas.Range("A" & mas.Rows.Count).End(xlUp).Offset(1).Row
wsLRow = ws.Range("A" & ws.Rows.Count).End(xlUp).Row
ws.Range("A2:A" & wsLRow).Copy mas.Range("A" & LRow)
mas.Range(mas.Cells(LRow, 2), mas.Cells(wsLRow + LRow - 2, 2)) = ws.Name
End If
Next ws
Application.ScreenUpdating = True
End Sub
To paste values change
ws.Range("A2:A" & wsLRow).Copy mas.Range("A" & LRow)
to this
ws.Range("A2:A" & wsLRow).Copy
mas.Range("A" & LRow).PasteSpecial xlPasteValues
I am a total beginner and appreciate any help I can get.
Sheet1 has a list of 30 markets.
Market1
Market2
.
.
Market30
I have a script that loops through Sheet1 and creates a new sheet for every market.
Sheet2 has all my raw data.
Looping through Sheet2 I need to move every row to its corresponding market. Market ID is in column B.
1-by-1 I can do this with the code below, but how would I put it in a loop?
I want to loop through Sheet1 and for each market ID, use that input as a variable to search Sheet2 and move the entire row to its corresponding market sheet.
Sub Market1()
Dim LR As Long, i As Long
With Sheets("Sheet2")
LR = .Range("B" & Rows.Count).End(xlUp).Row
For i = 1 To LR
If .Range("B" & i).Value = "Market1" Then .Rows(i).Copy Destination:=Sheets("Market1").Range("A" & Rows.Count).End(xlUp).Offset(1)
Next i
End With
End Sub
Sub Market2()
Dim LR As Long, i As Long
With Sheets("Sheet2")
LR = .Range("B" & Rows.Count).End(xlUp).Row
For i = 1 To LR
If .Range("B" & i).Value = "Market2" Then .Rows(i).Copy Destination:=Sheets("Market2").Range("A" & Rows.Count).End(xlUp).Offset(1)
Next i
End With
End Sub
Thank you
I think this should do what you want. The only tricky thing is adding a sheet if you already have the sheet name. I added a second macro that checks for it and creates if not found. Based on your code (which was a nice example), I think this should work for you.
Sub MarketAny()
Dim LR As Long, i As Long
Dim ws As Worksheet, shName As String
Set ws = Sheets("Sheet2")
LR = ws.Range("B" & ws.Rows.Count).End(xlUp).Row
For i = 1 To LR
shName = ws.Range("B" & i).Value
Call SheetCheck(shName) ' needed to ensure that you don't create a duplicate name
ws.Rows(i).Copy Destination:=Sheets(shName).Range("A" & Rows.Count).End(xlUp).Offset(1)
Next i
End Sub
Private Sub SheetCheck(nameofSheet As String)
Dim ws As Worksheet
For Each ws In ThisWorkbook.Sheets
If ws.Name = nameofSheet Then Exit Sub
Next ws
'Creates new sheet
Set ws = Sheets.Add
ws.Name = nameofSheet
End Sub