I am new to this and don't know why my sheet is not copying over the the new worksheet? I can't find the error in my VBA.
Private Sub Adminminreport_Click()
Application.ScreenUpdating = False
Dim i&, LR&, count&
LR = Worksheets("Parts").Range("J" & Rows.count).End(xlUp).Row
Set newWS = Worksheets.Add
Worksheets("Parts").Range(Worksheets("Parts").Cells(1, 1), Worksheets("Parts").Cells(1, 13)).Copy newWS.Range("A1")
count = 2
For i = 2 To LR
If Range("J" & i).Value < Range("L" & i).Value Then
Worksheets("Parts").Range(Worksheets("Parts").Cells(i, 1), Worksheets("Parts").Cells(i, 13)).Copy newWS.Range("A" & count)
count = count + 1
End If
Next i
Application.ScreenUpdating = True
Unload Me
newWS.Activate
End Sub
It's good practice to always qualify a Range object with its parent worksheet. Otherwise you're relying on a certain sheet being active when your code runs...
Private Sub Adminminreport_Click()
Dim i As Long, LR As Long, count As Long
Dim newWS As Worksheet, partsWS As Worksheet
Set newWS = Worksheets.Add()
Set partsWS = Worksheets("Parts")
Application.ScreenUpdating = False
LR = partsWS.Range("J" & Rows.count).End(xlUp).Row
Range(partsWS.Cells(1, 1), partsWS.Cells(1, 13)).Copy _
newWS.Range("A1")
count = 2
For i = 2 To LR
If partsWS.Range("J" & i).Value < partsWS.Range("L" & i).Value Then
Range(partsWS.Cells(i, 1), partsWS.Cells(i, 13)).Copy _
newWS.Range("A" & count)
count = count + 1
End If
Next i
Application.ScreenUpdating = True
newWS.Activate
Unload Me
End Sub
Related
I have an Excel sheet with 50,000+ rows of data from A:N. I have a Master Data Sheet that has a query in the BackupData worksheet. I currently copy that data and paste as values into the Backup worksheet. With the headers:
ID
Vendor #
Name
Customer #
Customer
Invoice #
Date
Item#
Item Description
Qty
B/C
Lbs
Amt
Amt#2
I am trying to loop through all of these rows and copy the range of cells A:N until the first value change in Column A, the first different ID #.
I then need to paste the selected range into a new workbook.
Basically, I want to do the opposite of consolidating.
Sub inserting()
Dim wsBData, wsExport, wsCoverSht, wsBackup As Worksheet
Dim wbAllRebates, wbSingle As Workbook
Set wbAllRebates = ActiveWorkbook
Set wsBData = wbAllRebates.Sheets("BackupData")
Set wsBackup = wbAllRebates.Sheets("Backup")
Dim rID, rTopRow As Range
Dim i As Long
Dim Counter As Integer
i = 3
Set rTopRow = Rows(1)
Set rID = wsBackup.Range("A1")
wsBData.Cells.Copy
wsBackup.Cells.PasteSpecial Paste:=xlPasteValues
Counter = 0
LastRow = ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row
Do
If rID.Offset(i).Value <> rID.Offset(i - 1).Value Then
Rows(rID.Offset(i).Row).Insert shift:=xlDown
Call SubTotals(rID.Offset(i), rTopRow)
i = i + 1
Set rTopRow = Rows(rID.Offset(i).Row)
End If
Exit Do
Loop
MsgBox i
End Sub
Sub SubTotals(rID As Range, firstRow As Range)
rID.Value = "Total"
rID.Offset(, 9).Value = Application.WorksheetFunction.Sum(Range(firstRow.Cells(1, 10).Address & ":" & rID.Offset(-1, 1).Address))
End Sub
Try
Option Explicit
Sub SeparateWB()
Dim wsBData As Worksheet, wsBackup As Worksheet, wb As Workbook
Dim wbAllRebates As Workbook, rngHeader As Range
Dim i As Long, n As Long, LastRow As Long, StartRow As Long
Set wbAllRebates = ActiveWorkbook
With wbAllRebates
Set wsBData = .Sheets("BackupData")
Set wsBackup = .Sheets("Backup")
End With
wsBData.Cells.Copy
wsBackup.Cells.PasteSpecial Paste:=xlPasteValues
StartRow = 2
Application.ScreenUpdating = False
With wsBackup
LastRow = .Range("A" & .Rows.Count).End(xlUp).Row
Set rngHeader = .Range("A1:N1")
For i = 2 To LastRow
' change ID next row
If .Cells(i, "A") <> .Cells(i + 1, "A") Then
' create new workbook
Set wb = Workbooks.Add(1)
rngHeader.Copy wb.Sheets(1).Range("A1")
.Range("A" & StartRow & ":N" & i).Copy wb.Sheets(1).Range("A2")
wb.SaveAs .Cells(i, "A") & ".xlsx"
wb.Close False
' move to next
StartRow = i + 1
n = n + 1
End If
Next
End With
Application.ScreenUpdating = True
MsgBox n & " workbooks created"
End Sub
I'm trying to get my spreadsheet to automatically generate new names and sheets based on a data dump. I currently have the sheet working so that it will generate the name and sheet for each row of data, but I cannot get it to populate the sheet using that row.
There is a specific section of code that I cannot get to work:
For Each Nm In shNAMES
If Not Evaluate("ISREF('" & CStr(Nm.Text) & "'!A1)") Then
wsTEMP.Copy After:=.Sheets(.Sheets.Count)
ActiveSheet.Name = CStr(Nm.Text)
ActiveSheet.Range("A1:I1").Value = wsMASTER.Range("A" & Nm & ":I" & Nm) ' <<< This line here
End If
Next Nm
I know that the issue is using Nm to reference the cell (it's returning "OP01" which is the cell contents), but I'm trying to not add another workaround. I've tried using other functions to do similar after the Nm loop has finished, but can't seem to get those working either. Surely the answer has to be simple and I'm just missing something?
Option Explicit
Sub SheetsFromTemplate()
Application.ScreenUpdating = False
Rows("1:8").EntireRow.Delete
Call CreateLONums
Dim wsMASTER As Worksheet, wsTEMP As Worksheet, wsINDEX As Worksheet, wasVISIBLE As Boolean
Dim shNAMES As Range, Nm As Range
Dim firstrow As Long, lastrow As Long
With ThisWorkbook
Set wsTEMP = .Sheets("Template")
wasVISIBLE = (wsTEMP.Visible = xlSheetVisible)
If Not wasVISIBLE Then wsTEMP.Visible = xlSheetVisible
Set wsMASTER = .Sheets("Creation Page")
Set wsINDEX = .Sheets("Local Options")
With Sheets("Creation Page").Columns("A")
If WorksheetFunction.CountA(.Cells) = 0 Then
MsgBox "Sorry: no data"
Else
With .SpecialCells(xlCellTypeConstants)
firstrow = .Areas(1).Row
lastrow = .Areas(.Areas.Count).Cells(.Areas(.Areas.Count).Rows.Count).Row
End With
End If
End With
Set shNAMES = wsMASTER.Range("A" & firstrow, "A" & lastrow)
For Each Nm In shNAMES
If Not Evaluate("ISREF('" & CStr(Nm.Text) & "'!A1)") Then
wsTEMP.Copy After:=.Sheets(.Sheets.Count)
ActiveSheet.Name = CStr(Nm.Text)
ActiveSheet.Range("A1:I1").Value = wsMASTER.Range("A" & Nm & ":I" & Nm)
End If
Next Nm
wsINDEX.Activate
If Not wasVISIBLE Then wsTEMP.Visible = xlSheetHidden
End With
Worksheets("Creation Page").Delete
Worksheets("Template").Delete
Call CreateLinksToAllSheets
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub
Sub CreateLONums()
Dim firstrow As Long, lastrow As Long, rowcount As Integer
Columns("A:A").Insert Shift:=xlToRight
With Sheets("Creation Page").Columns("B")
If WorksheetFunction.CountA(.Cells) = 0 Then
MsgBox "Sorry: no data"
Else
With .SpecialCells(xlCellTypeConstants)
firstrow = .Areas(1).Row
lastrow = .Areas(.Areas.Count).Cells(.Areas(.Areas.Count).Rows.Count).Row
End With
End If
For rowcount = firstrow To firstrow + 9
Range("A" & rowcount).Value = "OP0" & rowcount - firstrow + 1
Next rowcount
For rowcount = firstrow + 9 To lastrow
Range("A" & rowcount).Value = "OP" & rowcount - firstrow + 1
Next rowcount
End With
End Sub
Appreciate any insight available.
Managed to work it out, took way longer than it should have -.-'
I borrowed a bit of Function code to reference the number from column A, then used that to reference the cells that I wanted.
For Each Nm In shNAMES
rownum = GetDigits(Nm) 'This bit here is calling the function
If Not Evaluate("ISREF('" & CStr(Nm.Text) & "'!A1)") Then
wsTEMP.Copy after:=.Sheets(.Sheets.Count)
ActiveSheet.Name = CStr(Nm.Text)
ActiveSheet.Range("A1:J1").Value = wsMASTER.Range("A" & rownum & ":J" & rownum).Value `This is utilising rownum to reference the cells
End If
Next Nm
Function code can be found here: How to find numbers from a string?
Entire code section in case it is useful to someone in future:
Option Explicit
Sub SheetsFromTemplate()
Application.ScreenUpdating = False
Rows("1:8").EntireRow.Delete
Call CreateLONums
Dim wsMASTER As Worksheet, wsTEMP As Worksheet, wsINDEX As Worksheet, wasVISIBLE As Boolean
Dim shNAMES As Range, Nm As Range
Dim firstrow As Long, lastrow As Long, rownum As Integer
With ThisWorkbook
Set wsTEMP = .Sheets("Template")
wasVISIBLE = (wsTEMP.Visible = xlSheetVisible)
If Not wasVISIBLE Then wsTEMP.Visible = xlSheetVisible
Set wsMASTER = .Sheets("Creation Page")
Set wsINDEX = .Sheets("Local Options")
With Sheets("Creation Page").Columns("A")
If WorksheetFunction.CountA(.Cells) = 0 Then
MsgBox "No Data Available"
Else
With .SpecialCells(xlCellTypeConstants)
firstrow = .Areas(1).Row
lastrow = .Areas(.Areas.Count).Cells(.Areas(.Areas.Count).Rows.Count).Row
End With
End If
End With
Set shNAMES = wsMASTER.Range("A" & firstrow, "A" & lastrow)
For Each Nm In shNAMES
rownum = GetDigits(Nm)
If Not Evaluate("ISREF('" & CStr(Nm.Text) & "'!A1)") Then
wsTEMP.Copy after:=.Sheets(.Sheets.Count)
ActiveSheet.Name = CStr(Nm.Text)
ActiveSheet.Range("A1:J1").Value = wsMASTER.Range("A" & rownum & ":J" & rownum).Value
End If
Next Nm
wsINDEX.Activate
If Not wasVISIBLE Then wsTEMP.Visible = xlSheetHidden
End With
Worksheets("Template").Move after:=Worksheets(Worksheets.Count)
Worksheets("Creation Page").Move after:=Worksheets(Worksheets.Count)
Call CreateLinksToAllSheets
Call UpdateIndexTechSpec
Call UpdateIndexOptDescription
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub
Sub CreateLONums()
Dim firstrow As Long, lastrow As Long, rowcount As Integer
Columns("A:A").Insert Shift:=xlToRight
With Sheets("Creation Page").Columns("B")
If WorksheetFunction.CountA(.Cells) = 0 Then
MsgBox "Sorry: no data"
Else
With .SpecialCells(xlCellTypeConstants)
firstrow = .Areas(1).Row
lastrow = .Areas(.Areas.Count).Cells(.Areas(.Areas.Count).Rows.Count).Row
End With
End If
For rowcount = firstrow To firstrow + 9
Range("A" & rowcount).Value = "OP0" & rowcount - firstrow + 1
Next rowcount
For rowcount = firstrow + 9 To lastrow
Range("A" & rowcount).Value = "OP" & rowcount - firstrow + 1
Next rowcount
End With
End Sub
Sub CreateLinksToAllSheets()
Dim sh As Worksheet
Dim cell As Range
Sheets("Local Options").Activate
ActiveSheet.Cells(10, 1).Select
For Each sh In ActiveWorkbook.Worksheets
If ActiveSheet.Name <> sh.Name Then
ActiveCell.Hyperlinks.Add Anchor:=Selection, Address:="", SubAddress:="'" & sh.Name & "'" & "!A1", TextToDisplay:=sh.Name
ActiveCell.Offset(1, 0).Select
End If
Next sh
Call UpdateIndexTechSpec
Call UpdateIndexOptDescription
End Sub
Sub UpdateIndexTechSpec()
Dim sh As Worksheet
Dim cell As Range
Sheets("Local Options").Activate
ActiveSheet.Cells(10, 2).Select
For Each sh In ActiveWorkbook.Worksheets
If ActiveSheet.Name <> sh.Name Then
ActiveCell.Value = sh.Range("B2").Value
ActiveCell.Offset(1, 0).Select
End If
Next sh
End Sub
Sub UpdateIndexOptDescription()
Dim sh As Worksheet
Dim cell As Range
Sheets("Local Options").Activate
ActiveSheet.Cells(10, 3).Select
For Each sh In ActiveWorkbook.Worksheets
If ActiveSheet.Name <> sh.Name Then
ActiveCell.Value = sh.Range("D2").Value
ActiveCell.Offset(1, 0).Select
End If
Next sh
End Sub
Function GetDigits(ByVal s As String) As String
Dim char As String
Dim i As Integer
GetDigits = ""
For i = 1 To Len(s)
char = Mid(s, i, 1)
If char >= "0" And char <= "9" Then
GetDigits = GetDigits + char
End If
Next i
End Function
VBA amateur here, I am writing a code to automate some processes in my workplace, i am however stuck in trying to overwrite all contents from workseets of the same name from one workbook to another.
My current process is as follows.
I store the macro in workbook 1
I open the worksheet which i wish to run the macro on
I run the macro
Ideally the macro should run the code below onto every worksheet and following which overwrite the data of a similar worksheet name in my master workbook. It is likely to be 40 different sheets with static worksheet name.
example: copy contents in worksheet("Asia") of workbook A into worksheet("Asia") of master workbook.
Please advise if this can be done in vba.
I tried looking up solutions on this site but is unable to find a solution.
Dim wk As Worksheet
For Each wk In ActiveWorkbook.Worksheets
wk.Activate
Dim TR As Integer
TR = Range("S" & Rows.Count).End(xlUp).Row
Range("Z4").Formula = "=CONCATENATE(TEXT(D4,""mm/dd/yyyy""),S4,M4)"
Range("Z4").Copy
Range("Z4:Z" & TR).PasteSpecial xlPasteAll
Application.CutCopyMode = False
Dim UR As Integer
UR = Range("S" & Rows.Count).End(xlUp).Row
Range("AA4").Formula = "=CONCATENATE(TEXT(D4,""mm/dd/yyyy""),S4,F4)"
Range("AA4").Copy
Range("AA4:AA" & UR).PasteSpecial xlPasteAll
Application.CutCopyMode = False
Dim DR As Integer
DR = Range("S" & Rows.Count).End(xlUp).Row
Range("AB4").Formula = "=CONCATENATE(TEXT(A4,""mm/dd/yyyy""),S4,K4)"
Range("AB4").Copy
Range("AB4:AB" & DR).PasteSpecial xlPasteAll
Application.CutCopyMode = False
Dim FR As Integer
FR = Range("S" & Rows.Count).End(xlUp).Row
Range("AC4").Formula = "=CONCATENATE(TEXT(A4,""mm/dd/yyyy""),S4,K4)"
Range("AC4").Copy
Range("AC4:AC" & FR).PasteSpecial xlPasteAll
Application.CutCopyMode = False
ActiveSheet.Range("A1").Value = Date
ActiveSheet.Range("A1").Formula = "=TEXT(TODAY(),""dd/mm/yyyy"")"
Last = Cells(Rows.Count, "A").End(xlUp).Row
For j = Last To 1 Step -1
If ActiveSheet.Cells(j, 1) > ActiveSheet.Range("A1") Then
ActiveSheet.Cells(j, 29).FormulaR1C1 = "=CONCATENATE(RC[-10], RC[-18])"
End If
Next j
Next wk
End Sub
My code for the spreadsheet above work, i am just figuring out how i can update the data in my master workbook.
Sub so()
Dim wb As Workbook
Dim wb1 As Workbook
Set wb = Workbooks("SourceWorkbook.xlsx")
Set wb1 = Workbooks("MasterWorkbook.xlsx")
Dim wk As Worksheet
Dim wm As Worksheet
Set wm = wb1.Worksheets("Asia")
For Each wk In wb.Worksheets
wk.Activate
If (wk.Name = "Asia") Then
Dim TR As Integer
TR = wk.Range("S" & Rows.Count).End(xlUp).Row
wk.Range("Z4").Formula = "=CONCATENATE(TEXT(D4,""mm/dd/yyyy""),S4,M4)"
wk.Range("Z4:Z" & TR).Copy wm.Range("Z4")
Application.CutCopyMode = False
Dim UR As Integer
UR = wk.Range("S" & Rows.Count).End(xlUp).Row
wk.Range("AA4").Formula = "=CONCATENATE(TEXT(D4,""mm/dd/yyyy""),S4,F4)"
wk.Range("AA4:AA" & UR).Copy wm.Range("AA4")
Application.CutCopyMode = False
Dim DR As Integer
DR = wk.Range("S" & Rows.Count).End(xlUp).Row
wk.Range("AB4").Formula = "=CONCATENATE(TEXT(A4,""mm/dd/yyyy""),S4,K4)"
wk.Range("AB4:AB" & DR).Copy wm.Range("AB4")
Application.CutCopyMode = False
Dim FR As Integer
FR = wk.Range("S" & Rows.Count).End(xlUp).Row
wk.Range("AC4").Formula = "=CONCATENATE(TEXT(A4,""mm/dd/yyyy""),S4,K4)"
wk.Range("AC4:AC" & FR).Copy wm.Range("AC4")
Application.CutCopyMode = False
ActiveSheet.Range("A1").Value = Date
ActiveSheet.Range("A1").Formula = "=TEXT(TODAY(),""dd/mm/yyyy"")"
Last = Cells(Rows.Count, "A").End(xlUp).Row
For j = Last To 1 Step -1
If ActiveSheet.Cells(j, 1) > ActiveSheet.Range("A1") Then
ActiveSheet.Cells(j, 29).FormulaR1C1 = "=CONCATENATE(RC[-10], RC[-18])"
End If
Next j
End If
Next wk
End Sub
I'm a total novice with VBA. I have the following code which does a matching exercise and then pastes the relevant values into col. B. my issue is each time the code is used the col will change how can I add this to the module so that it looks for the last cell used in row 1 and pastes the values below.
Sub TransferData()
Dim i As Long, j As Long, lastrow1 As Long, lastrow2 As Long
Dim myname As String
Application.ScreenUpdating = False
lastrow1 = Sheets("Input Sheet").Range("B" & Rows.Count).End(xlUp).Row
For i = 2 To lastrow1
myname = Sheets("Input Sheet").Cells(i, "B").Value
Sheets("Data").Activate
lastrow2 = Sheets("Data").Range("A" & Rows.Count).End(xlUp).Row
For j = 2 To lastrow2
If Sheets("Data").Cells(j, "A").Value = myname Then
Sheets("Input Sheet").Activate
Sheets("Input Sheet").Cells(i, "c").Copy
Sheets("Data").Activate
Sheets("Data").Cells(j, "B").Select
ActiveSheet.PasteSpecial
End If
Next j
Application.CutCopyMode = False
Next i
Application.ScreenUpdating = True
End Sub
any assistance with this would be appreciated.
You can replace your second For j = 2 To lastrow2 with the Match function.
Also, there is no need to Activate the sheets back and fourth all the time, just use fully qualified Ranges instead.
Code
Option Explicit
Sub TransferData()
Dim i As Long, j As Long, lastrow1 As Long, lastrow2 As Long
Dim myname As String
Dim MatchRng As Range
Application.ScreenUpdating = False
j = 2
With Sheets("Input Sheet")
lastrow1 = .Range("B" & .Rows.Count).End(xlUp).Row
' the 2 lines bellow should be outisde the loop
lastrow2 = Sheets("Data").Range("A" & Sheets("Data").Rows.Count).End(xlUp).Row
Set MatchRng = Sheets("Data").Range("A2:A" & lastrow2)
For i = 2 To lastrow1
myname = .Range("B" & i).Value
If Not IsError(Application.Match(myname, MatchRng, 0)) Then '<-- if successful Match
Sheets("Data").Range("B" & j).Value = .Range("C" & i).Value
j = j + 1
End If
Application.CutCopyMode = False
Next i
End With
Application.ScreenUpdating = True
End Sub
I have three macros that compare two columns
The one I am using is vary slow on a large file but works
Sub MatchPermissionGiverAndTarget()
Dim LastRow As Long
Dim ws As Excel.Worksheet
GoFast False
Set ws = ActiveWorkbook.Sheets("Helper")
LastRow = ws.Range("A" & ws.Rows.count).End(xlUp).Row
Range("E1").EntireColumn.Insert
Range("E1").FormulaR1C1 = "name"
With ws.Range("E2:E" & LastRow)
.Formula = "=INDEX(B:B,MATCH($D2,$B:$B,0))"
.Value = .Value
End With
Columns("D:D").EntireColumn.Delete
GoFast True
End Sub
And this one I found by #mehow Here: Fast compare method of 2 columns
But I can not figure out how to apply it so it dose what the first one dose
Any help on this is appreciated
Sub Main()
Application.ScreenUpdating = False
Dim stNow As Date
stNow = Now
Dim arr As Variant
arr = Range("B2:A" & Range("B" & Rows.Count).End(xlUp).Row).Value
Range("E1").EntireColumn.Insert
Range("E1").FormulaR1C1 = "name"
Dim varr As Variant
varr = Range("D2:D" & Range("D" & Rows.Count).End(xlUp).Row).Value
Dim x, y, match As Boolean
For Each x In arr
match = False
For Each y In varr
If x = y Then match = True
Next y
If Not match Then
Range("D" & Range("D" & Rows.Count).End(xlUp).Row + 1) = x
End If
Next
Columns("D:D").EntireColumn.Delete
Debug.Print DateDiff("s", stNow, Now)
Application.ScreenUpdating = True
End Sub
Or This one from same thread by #Reafidy
Sub HTH()
Application.ScreenUpdating = False
With Range("E2", Cells(Rows.Count, "E").End(xlUp)).Offset(, 1)
.Formula = "=VLOOKUP(B2,D:D,1,FALSE)"
.Value = .Value
.SpecialCells(xlCellTypeConstants, 16).Offset(, -1).Copy Range("D" & Rows.Count).End(xlUp).Offset(1)
.ClearContents
End With
Application.ScreenUpdating = True
End Sub
try this one:
Sub Main()
Dim ws As Worksheet
Dim stNow As Date
Dim lastrow As Long, lastrowB As Long
Dim match As Boolean
Dim k As Long
Dim arr, varr, v, a, res
Application.ScreenUpdating = False
stNow = Now
Set ws = ActiveWorkbook.Sheets("Helper")
With ws
lastrow = .Range("A" & .Rows.Count).End(xlUp).Row
lastrowB = .Range("B" & .Rows.Count).End(xlUp).Row
arr = .Range("B2:B" & lastrowB).Value
varr = .Range("D2:D" & lastrow).Value
.Range("E1").EntireColumn.Insert
.Range("E1").FormulaR1C1 = "name"
End With
k = 1
ReDim res(1 To lastrow, 1 To 1)
For Each v In varr
match = False
'if value from column D (v) contains in column B
For Each a In arr
If a = v Then
match = True
Exit For
End If
Next a
If match Then
res(k, 1) = v
Else
res(k, 1) = CVErr(xlErrNA)
End If
k = k + 1
Next v
With ws
.Range("E2:E" & lastrow).Value = res
.Range("D:D").Delete
End With
Debug.Print DateDiff("s", stNow, Now)
Application.ScreenUpdating = True
End Sub