I'm working with two workbooks. In the first I search for the value in the cell to the right of "Charge Number". Take that value and search the second workbooks pivot table for the matching row, copy it and go back to first work book and paste the data. This works great once. But I'm unable to get a loop to look for the next instance of "Charge Number" and repeat the process. The loop I have in the code isn't right because it finds the first value fine but then searches every next row for the same Charge Number.
Sub FindChargeNo()
Dim Loc As Range
Dim ChgNum As String
Dim SrchRng2 As String
Dim pvt As PivotTable
Dim wb As Workbook, ws As Worksheet
Dim FstWB As Workbook
Dim SecWB As Workbook
Dim rng As Range
Set FstWB = Workbooks("First.xlsm")
Set SecWB = Workbooks("Second_test.xlsx")
Set ws1 = FstWB.Worksheets("New Development")
Set ws = SecWB.Worksheets("Aug 18 Report")
Set pvt = ws.PivotTables(1)
lastRow = FstWB.Worksheets("New Development").Range("J" & Rows.Count).End(xlUp).Row
For i = 1 To lastRow
Set Loc = ws1.Cells.Find(What:="Charge Number")
If Not Loc Is Nothing Then
ChgNum = Loc.Offset(0, 1).Value
Debug.Print ChgNum
Debug.Print SrchRng
With pvt.PivotFields("Project WBS").PivotItems(ChgNum).LabelRange
Set rng = ws.Range(.Resize(.Rows.Count, pvt.TableRange1.Columns.Count).Address)
ws.Range(rng.Address).Copy
End With
SrchRng2 = Loc.Offset(0, 5).Address
FstWB.Worksheets("New Development").Range(SrchRng2).PasteSpecial
Set Loc = ws1.Cells.FindNext(Loc)
Loop While Loc.Address <> firstAddress
End If
Next
End Sub
Related
I'm working on simplifying an excel worksheet and I want information in the rows to be transferred based on the value. If the value = "done", I want it transferred to Carc. If the value = "On-going", I want it transferred to Ccon (haven't typed this up yet). This have been written-up in VBA but I'm open to trying other things if it would make things easier.
Main thing is that I'm trying to find a way to make the code already made, simpler and more practical. Only thing I haven't figured out is how to have it select 1 individual row, instead of all rows.
Sub MoveBasedOnValue2()
Dim TakeCell As Range
Dim DestCell As Range
Dim Status As Range
Dim Cjob As Worksheet
Dim CArc As Worksheet
Dim Contact As Range, Subject As Range, JobNo As Range, QuoteNo As Range
Dim Dateofcommision As Range, Ddate As Range
Set Cjob = Sheet4
Set CArc = Sheet1
If Cjob.Range("G2") = "Done" Then
Set Contact = Cjob.Range("A2")
Set Subject = Cjob.Range("B2")
Set QuoteNo = Cjob.Range("C2")
Set JobNo = Cjob.Range("D2")
Set Dateofcommision = Cjob.Range("E2")
Set Ddate = Cjob.Range("F2")
Status.Select
Contact.Select
Subject.Select
QuoteNo.Select
JobNo.Select
Dateofcommision.Select
Ddate.Select
If CArc.Range("A2") = "" Then
Set DestCell = CArc.Range("A2")
Else
Set DestCell = CArc.Range("A1").End(xlDown).Offset(1, 0)
End If
Contact.Copy DestCell
Subject.Copy DestCell.Offset(0, 1)
QuoteNo.Copy DestCell.Offset(0, 2)
JobNo.Copy DestCell.Offset(0, 3)
Dateofcommision.Copy DestCell.Offset(0, 4)
Ddate.Copy DestCell.Offset(0, 5)
Status.ClearContents
Contact.ClearContents
Subject.ClearContents
QuoteNo.ClearContents
JobNo.ClearContents
Dateofcommision.ClearContents
Ddate.ClearContents
End If
You can do something like this:
Sub MoveBasedOnValue2()
Dim cStatus As Range, wsDest As Worksheet
Set cStatus = Sheet4.Range("G2") 'first cell to check status
Do While Len(cStatus.Value) > 0
Select Case LCase(cStatus.Value)
Case "done": Set wsDest = Sheet1
Case "on-going": Set wsDest = Sheet2 'for example
Case Else: Set wsDest = Nothing 'no move to make
End Select
If Not wsDest Is Nothing Then 'got a destination sheet?
'here Range("A1:F2") is *relative* to the whole row...
cStatus.EntireRow.Range("A1:F2").Cut _
Destination:=wsDest.Cells(Rows.Count, "A").End(xlUp).Offset(1)
End If
Set cStatus = cStatus.Offset(1, 0) 'next source row
Loop
End Sub
I have this vba code that appends/distributes records from a Data mastersheet to individual named sheets. This is done based on column E's value. It works fine but ends in an error whenever it encounters a value on column E that's not one of the sheets in the file. Can you please help me so as to allow it to just skip those records and proceed with the processing? Thanks!
Sub CopyDataToSheets()
Dim copyfromws As Worksheet
Dim copytows As Worksheet
Dim cfrng As Range
Dim ctrng As Range
Dim cflr As Long
Dim ctlr As Long
Dim i As Long
Dim currval As String
Set copyfromws = Sheets("Data")
cflr = copyfromws.Cells(Rows.Count, "B").End(xlUp).Row
' Copy Row of Data to Specific Worksheet based on value in Column E
' Existing Formulas in Columns F through H or J are automatically extended to the new row of data
For i = 2 To cflr
currval = copyfromws.Cells(i, 1).Value
Set copytows = Sheets(currval)
ctlr = copytows.Cells(Rows.Count, "B").End(xlUp).Row + 1
Set cfrng = copyfromws.Range("A" & i & ":N" & i)
Set ctrng = copytows.Range("A" & ctlr & ":N" & ctlr)
ctrng.Value = cfrng.Value
Next
End Sub
I would make a small helper function that can test if the worksheet exists. That way you can control the logic of your loop.
Function SheetExists(sheetName As String, Optional wb As Workbook) As Boolean
If wb Is Nothing Then Set wb = ThisWorkbook
Dim ws As Worksheet
On Error Resume Next
Set ws = wb.Sheets(sheetName)
SheetExists = Err = 0
End Function
I am attempting to populate columns D-J of table1, with the values in table2, columns B-H. The values should be based upon the value of column C in table1.
I have the code below, but I believe that is copying the tables as is and not doing a check of the value in column C.
Images:
Sub wps()
Dim rng As Range
Dim strTable As String
Dim strAddress As String
Dim i As Long
With Worksheets("Procedures")
For i = 1 To .ListObjects.Count
strTable = .ListObjects(i).Name
Set rng = .ListObjects(strTable).Range
strAddress = rng.Cells(2, 3).Address
rng.Copy Destination:=Worksheets("Base Data").Range(strAddress)
With Worksheets("Base Data")
.ListObjects(i).Name = "quals"
End With
Next i
End With
End Sub
It looks like a destination.value=source.value situation, using a single Match(). You could wrap this in a loop on your destWS.
Maybe something like (mock-up, untested):
For i = 2 to lastRowDest
dim sourceWS as worksheet
set sourceWS = sheets(1)
dim destWS as worksheet
set destWS = sheets(2)
destinationSearchTerm = destWS.Cells(i,"C").Value
dim sourceRow as long
sourceRow = Application.Match(destinationSearchTerm, sourceWS.Columns("A"), 0)
destWS.Range(destWS.Cells(i,"D"), destWS.Cells(i,"J") = sourceWS.Range(sourceWS.Cells(sourceRow,"B"),sourceWS.Cells(sourceRow,"H")
Next i
The code below will create a new sheet for each cell in column A. The second module will copy all rows that have a specific value in column A to a specific destination.
I created this so each work order number gets its own sheet and all rows with that work order number is copied over to the sheet named that work order number.
The issue is there are 604 unique work order numbers and I have to edit the second module for each work order in order for it to work.
Is there some way I could have it loop through all the values in column A and maybe compare it to a set variable and then copy the rows to the sheet that has that work order number? I don't know how to make the destination sheet be whatever new value is found in column A.
I'm new to VBA, so this question probably doesn't make much sense. And yes I have seen code for creating and naming a sheet based on each new work order in one module but it generally won't compile so I split the process out to 2 modules.
Anyway, to better understand what I mean: say column A has 4 rows for work order number 1234. I'd need the macro to copy all 4 rows for 1234 into the sheet that is named 1234. Then move on to the next work order number.
The range it is checking for work orders in is A2:A39986, but the full range is A2:F39986.
Thank you for your time.
Option Explicit
Sub parse_data()
Dim xRCount As Long
Dim xSht As Worksheet
Dim xNSht As Worksheet
Dim I As Long
Dim xTRow As Integer
Dim xCol As New Collection
Dim xTitle As String
Dim xSUpdate As Boolean
Set xSht = ActiveSheet
On Error Resume Next
xRCount = xSht.Cells(xSht.Rows.Count, 1).End(xlUp).Row
xTitle = "A60:A604"
xTRow = xSht.Range(xTitle).Cells(1).Row
For I = 2 To xRCount
Call xCol.Add(xSht.Cells(I, 1).Text, xSht.Cells(I, 1).Text)
Next
xSUpdate = Application.ScreenUpdating
Application.ScreenUpdating = False
For I = 1 To xCol.Count
Call xSht.Range(xTitle).AutoFilter(1, CStr(xCol.Item(I)))
Set xNSht = Nothing
Set xNSht = Worksheets(CStr(xCol.Item(I)))
If xNSht Is Nothing Then
Set xNSht = Worksheets.Add(, Sheets(Sheets.Count))
xNSht.Name = CStr(xCol.Item(I))
Else
xNSht.Move , Sheets(Sheets.Count)
End If
xSht.Range("A" & xTRow & xRCount).EntireRow.Copy xNSht.Range("A60")
xNSht.Columns.AutoFit
Next
xSht.AutoFilterMode = False
xSht.Activate
Application.ScreenUpdating = xSUpdate
End Sub
and the module that copies data to a specific destination:
Sub CopyColumnOver()
Dim wsSource As Worksheet
Dim wsDestin As Worksheet
Dim lngDestinRow As Long
Dim rngSource As Range
Dim rngCel As Range
Set wsSource = Sheets("Sheet1") 'Edit "Sheet1" to your source sheet name
Set wsDestin = Sheets("11556")
With wsSource
'Following line assumes column headers in Source worksheet so starts at row2
Set rngSource = .Range(.Cells(2, "A"), .Cells(.Rows.Count, "A").End(xlUp))
End With
For Each rngCel In rngSource
If rngCel.Value = "11556" Then
With wsDestin
'Following line assumes column headers in Destination worksheet
lngDestinRow = .Cells(.Rows.Count, "A").End(xlUp).Offset(1, 0).Row
rngCel.EntireRow.Copy Destination:=wsDestin.Cells(lngDestinRow, "A")
End With
End If
Next rngCel
End Sub
I am stuck writing this Excel macro and could kindly use some help. I am trying to create a dynamic macro that will compare two tables in two different sheets and will update information for a row if different or copy a new row to the new table if not there. Both tables contain the same columns of info and have a unique product code per data row. Once a button is pressed, if the product code for the row in table1 is not found on the new table then that row will copy. If the product code is found in the new table but other information in columns is different, than that other information will be updated on the new table. If the product code is found and the other information is the same then that row will not be copied. I need this for as many lines as possible in table1.
NOTE: I thought VLOOKUP may be the route to successfully code this macro...BELOW is my attempt so far to get this to work.
Sub Copy_Attempt()
Application.ScreenUpdating = False
Dim s1 As Worksheet, s2 As Worksheet
Set s1 = Sheets("Raw Data")
Set s2 = Sheets("BAS Linkage Master")
Dim i As Integer
Dim j As Integer
Dim Proj_ID As String
Dim Lookup_Range As Range
Dim Linkage_Lookup_Range As Range
Dim Raw_Percent_Complete As String
Dim Linkage_Percent_Complete As String
Set Lookup_Range = s1.Range("A1:O1000")
Set Linkage_Lookup_Range = s2.Range("A6:N1000")
For i = 2 To 1000
Proj_ID = s1.Range("F" & i).Value
Raw_Percent_Complete = Application.WorksheetFunction.VLookup(Proj_ID, Lookup_Range, 10, False)
Next
For j = 7 To 1000
Linkage_Percent_Complete = s2.Range("I" & j).Value
Next
If Raw_Percent_Complete = Linkage_Percent_Complete Then
' DO NOT COPY THAT ROW OVER
Else
Percent_Complete = Range("I" & j).Value
'UPDATE PERCENT COMPLETE FOR THAT SPECIFIC PRODUCT CODE
End If
Sheets("Raw Data").Activate
Columns("H").EntireColumn.Delete
Range("A2:P1000").Select
Selection.Copy
Sheets("BAS Linkage Master").Activate
Range("A" & Rows.Count).End(xlUp).Offset(1).Select
Selection.PasteSpecial
' Sheets("Welcome").Activate
' Range("A11:O11").ClearContents
Sheets("Raw Data").Activate
Range("A2:N10000").ClearContents
Application.CutCopyMode = False
Application.ScreenUpdating = True
Sheets("BAS Linkage Master").Activate
End Sub
This is a nice little script that looks for differences and highlights the differences.
Public Sub CompareSheets()
Dim ws1 As Worksheet, ws2 As Worksheet
Dim cell As Range, rng As Range
Set ws1 = Worksheets("Sheet1")
Set ws2 = Worksheets("Sheet2")
Set rng = ws1.Range("A1:B20")
For Each cell In rng
Celladdress = cell.Address
If cell <> ws2.Range(Celladdress) Then
cell.Interior.Color = vbYellow
ws2.Range(Celladdress).Interior.Color = vbYellow
End If
Next cell
End Sub
You can use the same concept to copy the values from one table to another.
Public Sub CompareSheets()
Dim ws1 As Worksheet, ws2 As Worksheet
Dim cell As Range, rng As Range
Set ws1 = Worksheets("Sheet1")
Set ws2 = Worksheets("Sheet2")
Set rng = ws1.Range("A1:B20")
For Each cell In rng
Celladdress = cell.Address
If cell <> ws2.Range(Celladdress) Then
ws2.Range(Celladdress).Value = ws1.Range(Celladdress).Value
End If
Next cell
End Sub