Below is the code I have tried with but it only worked for Column A, I want to do the same job with other columns:
Sub ColumnAMaster()
Dim lastRow As Long, lastRowMaster As Long
Dim ws As Worksheet
Dim Master As Worksheet
Application.ScreenUpdating = False
Set Master = Sheets.Add
Master.Name = "Master"
lastRowMaster = 1
For Each ws In ThisWorkbook.Sheets
If ws.Name <> "Master" Then
lastRow = ws.Range("A" & Rows.Count).End(xlUp).Row
ws.Range("A1:A" & lastRow).Copy Destination:=Master.Range("A" & lastRowMaster)
lastRowMaster = Master.Range("A" & Rows.Count).End(xlUp).Row + 1
End If
Next
Application.ScreenUpdating = True
MsgBox "Done!"
End Sub
sub Master_data()
'declarations
Dim ws1 as worksheet
Dim ws2 as worksheet
Dim ws3 as worksheet
Dim ws4 as worksheet
Dim i as long
Dim lastrow_sh1 as long
Dim lastrow_sh4 as long
Dim wb as workbook
set wb= application.activeworkbook
set ws1=wb.sheets("sheet1")
set ws2=wb.sheets("sheet2")
set ws3=wb.sheets("sheet3")
set ws4=wb.sheets("sheet4")
lastrow_sh1= ws1.range("A1").end(xlup).row
ws4.cells(1,1)="name"
for i =2 to lastrow_sh1
if ws1.cells(i,1)=ws2.cells(i,1) & ws3.cell(i,1)then
lastrow_sh4=ws4.range(A1).end(xlup).row
ws4.cells(lastrow_sh4+1,1)=ws1.cells(i,1)
ws4.cells(lastrow_sh4+1,2)=ws1.cells(i,2)
ws4.cells(lastrow_sh4+1,3)=ws1.cells(i,3)
ws4.cells(lastrow_sh4+1,4)=ws3.cells(i,4)
endif
next i
end sub
Related
I need help one last time, code below works fine; it copies values (A1) from sheets that is in array to a new created sheet in org file. The last modyfication I want to make here, is that in this NOT_ORG file I want to copy range of values, rather than 1 value. This range always starts from A7, but the number of cols and rows might change. I want to copy this range dynamically and paste in in range(a1) in newly created sheet. I know that I should calculate lastRow & lastCol, but not sure where to put this code, and how to modify this last copy line to achieve this result.
Tagging #faneduru as he helped me initially.
Sub Test1()
Dim lastRow As Long
Dim WshtNames As Variant
Dim WshtNameCrnt As Variant
Dim WB1 As Workbook
Dim WB2 As Workbook
Set WB1 = ActiveWorkbook
Set WB2 = Workbooks.Open("C:\NOT_ORG.xlsx")
WshtNames = Array("2", "3")
For Each WshtNameCrnt In WshtNames
WB1.Sheets.Add.Name = WshtNameCrnt & "_new"
WB2.Worksheets(WshtNameCrnt).Range("A1").Copy ActiveSheet.Range("A1")
Next WshtNameCrnt
End Sub
Thanks in advance.
eM
Please, test the next code:
Sub Test1()
Dim lastRow As Long, lastCol As Long, WshtNames, WshtNameCrnt
Dim WB1 As Workbook, WB2 As Workbook, ws As Worksheet
Set WB1 = ActiveWorkbook
Set WB2 = Workbooks.Open("C:\NOT_ORG.xlsx")
WshtNames = Array("2", "3")
For Each WshtNameCrnt In WshtNames
WB1.Sheets.Add.Name = WshtNameCrnt & "_new"
Set ws = WB2.Worksheets(WshtNameCrnt)
lastRow = ws.Range("A" & ws.rows.count).End(xlUp).row
lastCol = ws.cells(7, ws.Columns.count).End(xlToLeft).Column
ws.Range(ws.Range("A" & 7), ws.cells(lastRow, lastCol)).Copy ActiveSheet.Range("A1")
Next WshtNameCrnt
End Sub
And a faster version, using an array:
Sub Test1Array()
Dim lastRow As Long, lastCol As Long, WshtNames, WshtNameCrnt
Dim WB1 As Workbook, WB2 As Workbook, ws As Worksheet, arr
Set WB1 = ActiveWorkbook
Set WB2 = Workbooks.Open("C:\NOT_ORG.xlsx")
WshtNames = Array("2", "3")
For Each WshtNameCrnt In WshtNames
WB1.Sheets.Add.Name = WshtNameCrnt & "_new"
Set ws = WB2.Worksheets(WshtNameCrnt)
lastRow = ws.Range("A" & ws.rows.count).End(xlUp).row
lastCol = ws.cells(7, ws.Columns.count).End(xlToLeft).Column
arr = ws.Range(ws.Range("A" & 7), ws.cells(lastRow, lastCol)).value
ActiveSheet.Range("A1").Resize(UBound(arr), UBound(arr, 2)).value = arr
Next WshtNameCrnt
End Sub
Hello i have a sub that copies from every sheet in the wb to a sheet named "Table", the sheets are structured with multiple tables and i need to copy the first table from the top, without the headers and aggregate every table contain from the sheets into sheet "Table":
Sub TableCopy()
Dim ws1 As Worksheet, _
LR1 As Long, _
LR2 As Long
Application.ScreenUpdating = False
For Each ws1 In ActiveWorkbook.Worksheets
If ws1.Name <> "Table" Then
LR1 = Sheets("Table").Range("H" & Rows.Count).End(xlUp).Row + 1
LR2 = ws1.Range("B8", Range("B8").End(xlDown)).Rows.Count - 1
ws1.Range("A:S" & LR2).Copy Destination:=Sheets("Table").Range("A" & LR1)
End If
Next ws1
Application.ScreenUpdating = True
End Sub
I'm getting
Method Range of 'object' worksheet failed
I just can't get the grasp of it, can you help me? thx
Two fixes:
Sub TableCopy()
Dim ws1 As Worksheet, _
LR1 As Long, _
LR2 As Long
Application.ScreenUpdating = False
For Each ws1 In ActiveWorkbook.Worksheets
If ws1.Name <> "Table" Then
LR1 = Sheets("Table").Range("H" & Sheets("Table").Rows.Count).End(xlUp).Row + 1 'Fix 1 (qualified the rows.count)
LR2 = ws1.Range("B8", Range("B8").End(xlDown)).Rows.Count - 1
ws1.Range("A2:S" & LR2).Copy Destination:=Sheets("Table").Range("A" & LR1) 'Fix 2 (added a # for starting row in copy range, assume row 1 is header)
End If
Next ws1
Application.ScreenUpdating = True
End Sub
Sub TableCopy()
Dim ws1 As Worksheet, _
LR1 As Long, _
LR2 As Long
Application.ScreenUpdating = False
For Each ws1 In ActiveWorkbook.Worksheets
If ws1.Name <> "Table" Then
LR1 = Worksheets("Table").Cells(Worksheets("Table").Rows.count, "H").End(xlUp).row + 1
LR2 = ws1.Cells(ws1.Rows.count, "B").End(xlUp).row - 9
ws1.Range("A2:S" & LR2).Copy Destination:=Worksheets("Table").Range("A" & LR1)
End If
Next ws1
Application.ScreenUpdating = True
End Sub
Beginner VBA scripter here. How can I fix my code so that it will search thru Sheet1 for the string array in strSearch and copy those rows into Sheet2?
Also, how can I extend the code to be able to search for a different string array and copy it into another worksheet?
Dim ws1 As Worksheet, ws2 As Worksheet
Dim copyFrom As Range
Dim lRow As Long
Dim lastRow As Long
Dim strSearch As Variant
Dim i As Integer
Set ws1 = Worksheets("Sheet1")
With ws1
.AutoFilterMode = False
lRow = .Range("J" & .Rows.Count).End(xlUp).Row
With .Range("J1:J" & lRow)
On Error Resume Next
strSearch = Array("John","Jim")
.AutoFilter Field:=1, Criteria1:=strSearch
Set copyFrom = .Offset(0).SpecialCells(xlCellTypeVisible).EntireRow
On Error GoTo 0
End With
Set ws2 = Worksheets("Sheet2")
With ws2
On Error Resume Next
lastRow = ws2.Cells.Find("*", SearchOrder:=xlByRows, LookIn:=xlValues, SearchDirection:=xlPrevious).Row
Set Rng = copyFrom.SpecialCells(xlCellTypeConstants)
Rng.Copy .Cells(lastRow + 1, "C")
copyFrom.Delete
On Error GoTo 0
End With
.AutoFilterMode = False
You could iterate through the lines and the array:
Option Explicit
Dim firstRowWs1 As Long
Dim lastRowWs1 As Long
Dim lastRowWs2 As Long
Dim searchColumnWs1 As Integer
Dim i As Integer
Dim check As Variant
Dim strSearch As Variant
Sub test()
lastRowWs1 = ws1.UsedRange.Rows.Count
lastRowWs2 = ws2.UsedRange.Rows.Count
firstRowWs1 = 2
searchColumnWs1 = 1
strSearch = Array("John", "Jim")
For i = firstRowWs1 To lastRowWs1
For Each check In strSearch
If check = ws1.Cells(i, searchColumnWs1).Value Then
ws1.Rows(i).Copy (ws2.Rows(lastRowWs2 + 1))
lastRowWs2 = lastRowWs2 + 1
ws1.Rows(i).Delete shift:=xlUp
i = i - 1
Exit For
End If
Next check
Next i
End Sub
Dim strsearchlocation as integer
strSearchLocation = Sheet1.Cells.Find(what:= strSearch, After:=[A1], SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).row
Sheet1.Rows(strSearchLocation).Copy
Finds and copies the row of strSearch
I am trying to use VBA in Excel to separate rows into separate sheets and retain headers. Below is what I have so far. It works except I get the header row, then the individual row I want to move to the sheet is there BUT it's there three times instead of one. I am basically going by trial and error and I am stumped. Help please! I have no experience with this:
Sub DispatchTimeSeriesToSheets()
Dim ws As Worksheet
Set ws = Sheets("Scoring")
Dim LastRow As Long
LastRow = Range("A" & ws.Rows.Count).End(xlUp).Row
' stop processing if we don't have any data
If LastRow < 2 Then Exit Sub
Application.ScreenUpdating = False
SortScoring LastRow, ws
CopyDataToSheets LastRow, ws
ws.Select
Application.ScreenUpdating = True
End Sub
Sub SortScoring(LastRow As Long, ws As Worksheet)
ws.Range("A4:W" & LastRow).Sort Key1:=ws.Range("A4"), Key2:=ws.Range("W4")
End Sub
Sub CopyDataToSheets(LastRow As Long, src As Worksheet)
Dim rng As Range
Dim cell As Range
Dim Series As String
Dim SeriesStart As Long
Dim SeriesLast As Long
Set rng = Range("A4:A" & LastRow)
SeriesStart = 2
Series = Range("A" & SeriesStart).Value
For Each cell In rng
If cell.Value <> Series Then
SeriesLast = cell.Row - 1
CopySeriesToNewSheet src, SeriesStart, SeriesLast, Series
Series = cell.Value
SeriesStart = cell.Row
End If
Next
' copy the last series
SeriesLast = LastRow
CopySeriesToNewSheet src, SeriesStart, SeriesLast, Series
End Sub
Sub CopySeriesToNewSheet(src As Worksheet, Start As Long, Last As Long, _
name As String)
Dim tgt As Worksheet
If (SheetExists(name)) Then
MsgBox "Sheet " & name & " already exists. " _
& "Please delete or move existing sheets before" _
& " copying data from the Scoring.", vbCritical, _
"Time Series Parser"
End
End If
Worksheets.Add(After:=Worksheets(Worksheets.Count)).name = name
Set tgt = Sheets(name)
' copy header row from src to tgt
tgt.Range("A1:W1").Value = src.Range("A1:W1").Value
' copy data from src to tgt
tgt.Range("A4:W" & Last - Start + 2).Value = _
src.Range("A" & Start & ":W" & Last).Value
End Sub
Function SheetExists(name As String) As Boolean
Dim ws As Worksheet
SheetExists = True
On Error Resume Next
Set ws = Sheets(name)
If ws Is Nothing Then
SheetExists = False
End If
End Function
Try this:
Sub doitall()
Dim ows As Worksheet
Dim tws As Worksheet
Dim rng As Range
Dim cel As Range
Dim LastRow As Long
Dim tLastRow As Long
Set ows = Sheets("Scoring")
With ows
LastRow = .Range("A" & .Rows.Count).End(xlUp).Row
Set rng = .Range("A4:A" & LastRow)
For Each cel In rng
If Not SheetExists(cel.Value) Then
Set tws = Worksheets.Add(After:=Sheets(Worksheets.Count))
tws.Name = cel.Value
tws.Rows(1).Resize(3).Value = .Rows(1).Resize(3).Value
Else
Set tws = Sheets(cel.Value)
End If
tLastRow = tws.Range("A" & tws.Rows.Count).End(xlUp).Offset(1).Row
tws.Rows(tLastRow).Value = .Rows(cel.Row).Value
Next
End With
End Sub
Function SheetExists(SName As String, _
Optional ByVal WB As Workbook) As Boolean
On Error Resume Next
If WB Is Nothing Then Set WB = ActiveWorkbook
SheetExists = CBool(Len(WB.Sheets(SName).Name))
End Function
This will do what you are looking for
Const HeaderRow = 3
Sub MoveRecordsByValues()
Dim ws As Worksheet
Dim dws As Worksheet
Dim SheetName As String
Application.DisplayAlerts = False
For Each ws In Sheets
If ws.name <> "Scoring" Then ws.Delete
Next ws
Set ws = Sheets("Scoring")
StartRow = HeaderRow + 1
LastRow = ws.Range("A" & ws.Rows.Count).End(xlUp).Row
For RowCounter = StartRow To LastRow
SheetName = ws.Cells(RowCounter, 1)
If Not SheetExists(SheetName) Then SetUpSheet SheetName, ws, HeaderRow
Set dws = Worksheets(SheetName)
DestLastRow = dws.Range("A" & dws.Rows.Count).End(xlUp).Row + 1
ws.Rows(RowCounter).Copy dws.Cells(DestLastRow, 1)
Next RowCounter
Application.DisplayAlerts = True
End Sub
Function SheetExists(name As String) As Boolean
SheetExists = True
On Error GoTo errorhandler
Sheets(name).Activate
Exit Function
errorhandler:
SheetExists = False
End Function
Sub SetUpSheet(name, SourceSheet, HeaderRow)
Dim DestSheet As Worksheet
Set DestSheet = Sheets.Add
DestSheet.name = name
SourceSheet.Rows(1).Copy DestSheet.Cells(1, 1)
SourceSheet.Rows(2).Copy DestSheet.Cells(2, 1)
SourceSheet.Rows(3).Copy DestSheet.Cells(3, 1)
End Sub
This code does what I want per entry in the txtKB textbox:
Dim ws1 As Worksheet
Dim lastrow As Long
Dim clipboardObj As New MSForms.DataObject
Dim wstest As Worksheet
Dim clipboardTxt As String
Set ws1 = Sheets("Sheet6")
Set wstest = Sheets("Sheet8")
lastrow = ws1.Range("A" & Rows.Count).End(xlUp).Row
ws1.Range("M1:A" & lastrow).AutoFilter field:=13, Criteria1:=txtKB
ws1.Range("B" & Rows.Count).End(xlUp).Offset(1).Select
txtmedian = WorksheetFunction.Aggregate(12, 5, Columns(2))
clipboardTxt = txtmedian.Text
clipboardObj.SetText clipboardTxt
clipboardObj.PutInClipboard
wstest.Range("A" & Rows.Count).End(xlUp).Offset(1) = txtmedian
but I want to improve it (so that I will not need to manually input the ID in textbox txtKB criteria anymore, and automate everything with just one click of a button) to take an entry in ws2 Column A (like an ID), look it up in ws1 then perform the median extraction, paste the median in wstest then move to the next ID in ws2 until it goes through all IDs in ws2.
Note: ws2 is not yet in the code.
I need to place a loop somewhere I just don't know where.
You could try something like:
Dim ws as worksheet
Dim wb as workbook
set wb = ThisWorkbook
For Each ws in wb.Worksheets
' Do what you want here
next ws
This will loop through all worksheets in the workbook
To work it into your code
Dim wb as workbook
Dim ws As Worksheet
Dim lastrow As Long
Dim clipboardObj As New MSForms.DataObject
Dim wstest As Worksheet
Dim clipboardTxt As String
set wb = ThisWorkbook
Set wstest = Sheets("Sheet8")
For Each ws in wb.Worksheets ' Loop through all sheets in workbook
if not ws.name = wstest.name then ' Avoid sheet you're copying too (ammend as needed)
With ws
lastrow = .Range("A" & Rows.Count).End(xlUp).Row
.Range("M1:A" & lastrow).AutoFilter field:=13, Criteria1:=txtKB
.Range("B" & Rows.Count).End(xlUp).Offset(1).Select
End With
txtmedian = WorksheetFunction.Aggregate(12, 5, Columns(2))
clipboardTxt = txtmedian.Text
clipboardObj.SetText clipboardTxt
clipboardObj.PutInClipboard
wstest.Range("A" & Rows.Count).End(xlUp).Offset(1) = txtmedian 'You will need to change your code to paste into different locations I would have assumed, I'll leave that up to you though
End if
Next ws