I created this macro to search through two spreadsheets and update one from the other based on unique keys that each row has. It will copy the first sheet to a temp sheet then unfilter and unhide everything. Next it will sort them by key so that they are all in order. after that it will move two columns to be excluded from the update to the front and update the rest. To update it will search through using the match function and if it comes up as an error (which means the row isn't there) it will add it to the end of the update sheet. Otherwise, it will copy and paste each row from the source to the update sheet. It all works but for some reason it won't update past line 24 and I have no idea why. I've stepped through it and it doesn't break, it just doesn't update. I am new to vba so any help would be greatly appreciated.
Sub crossUpdate()
Dim rng1 As Range, rng2 As Range, rng1Row As Range, rng2Row As Range, Key As Range, match As Variant
Dim wb1 As Workbook
Dim wb2 As Workbook
Dim endRng2 As Long
Set wb2 = Workbooks("011 High Level Task List v2.xlsm")
Set wb1 = Workbooks("011 High Level Task List v2 ESI.xlsm")
'Unfilter and Unhide both sheets
With wb1.Sheets("Development Priority List")
.Cells.EntireColumn.Hidden = False
.Cells.EntireRow.Hidden = False
.AutoFilterMode = False
End With
With wb2.Sheets("Development Priority List")
.Cells.EntireColumn.Hidden = False
.Cells.EntireRow.Hidden = False
.AutoFilterMode = False
End With
'Copy and paste original sheet to new temp sheet
wb1.Sheets("Development Priority List").Activate
wb1.Sheets("Development Priority List").Cells.Select
Selection.Copy
Sheets.Add.Name = "SourceData"
wb1.Sheets("SourceData").Paste
N = Cells(Rows.Count, "A").End(xlUp).Row
Set rng1 = wb1.Sheets("SourceData").Cells.Range("A2:A" & N)
Set rng1Row = rng1.EntireRow
'Sort temp sheet by key
wb1.Worksheets("SourceData").Sort.SortFields.Clear
wb1.Worksheets("SourceData").Sort.SortFields.Add Key:=wb1.Sheets("SourceData").Cells.Range("A2:A" & N), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
xlSortNormal
With wb1.Worksheets("SourceData").Sort
.SetRange Range("A1:Z1000")
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
'Sort update sheet by key
wb2.Activate
wb2.Worksheets("Development Priority List").Sort.SortFields.Clear
wb2.Worksheets("Development Priority List").Sort.SortFields.Add Key:=wb2.Sheets("Development Priority List").Cells.Range("A2:A" & N), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
xlSortNormal
With wb2.Worksheets("Development Priority List").Sort
.SetRange Range("A1:Z1000")
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
'Dev columns moved on SourceData sheet
wb1.Sheets("SourceData").Activate
Columns("F:G").Select
Selection.Cut
Columns("A:A").Select
Selection.Insert Shift:=xlToRight
'Dev columns moved on update sheet
wb2.Sheets("Development Priority List").Activate
Columns("F:G").Select
Selection.Cut
Columns("A:A").Select
Selection.Insert Shift:=xlToRight
'Update sheet searched and updated from SourceData
Set rng2 = wb2.Sheets("Development Priority List").Cells.Range("C2:C" & N)
endRng2 = rng2.Rows.Count
For i = 2 To rng1.Rows.Count + 1
Set Key = wb1.Sheets("SourceData").Range("C" & i)
match = Application.match(Key, rng2, 0)
'Rows that don't exsist in update sheet are added
If IsError(match) Then
wb1.Sheets("SourceData").Range("C" & i, "Z" & i).Copy
wb2.Sheets("Development Priority List").Range("C" & endRng2, "Z" & endRng2).Select
wb2.Sheets("Development Priority List").Paste
endRng2 = endRng2 + 1
'All other rows are scanned for changes
Else
For j = 3 To wb1.Sheets("SourceData").Range("C" & i, "Z" & i).Columns.Count
wb2.Sheets("Development Priority List").Cells(j, i).Value = wb1.Sheets("SourceData").Cells(j, i)
Next j
End If
Next i
'SourceData sheet deleted
Application.DisplayAlerts = False
wb1.Sheets("SourceData").Delete
Application.DisplayAlerts = True
'Dev columns moved back on update sheet
wb2.Sheets("Development Priority List").Activate
Columns("A:B").Select
Selection.Cut
Columns("H:H").Select
Selection.Insert Shift:=xlToRight
wb1.Activate
It took me a few times coming back to this to figure out what was wrong. Here is what I believe is happening:
This code:
For j = 3 To wb1.Sheets("SourceData").Range("C" & i, "Z" & i).Columns.Count
wb2.Sheets("Development Priority List").Cells(j, i).Value = wb1.Sheets("SourceData").Cells(j, i)
Next j
Is looping from 3 to the number of columns between "C" and "Z" (ALWAYS 24). The bit inside the FOR loop is using Cells(<row>, <column>) syntax to copy from one cell to another. Because J is always looping from 3 to 24 then ROWS 3 through 24 are the only ones that will be updated. Perhaps you meant Cells(i,j)?
Related
I have some data that will always be 8 columns (A-H) the number of rows could be different every time (Dynamic).
If the string in column A ends with:
"IT", "LN" or "SJ" then the row value in Column G needs to be divided by 100.
If the string ends in "KK" the value in Column G needs to be
divided by 1000.
Otherwise no math operation to the row needs to be performed.
The data also needs to be sorted alphabetically by column C then by column H.
After this is done the header row (1). Can be deleted.
What I have so far "works" but it results in a very long list of 0.0000 values in column G that makes copying out the cleaned data difficult.
Would anyone be able to show me a more efficient solution?
Sub Clean()
Dim wkb As Workbook
Set wkb = ActiveWorkbook
Dim ws As Worksheet
Set ws = ActiveSheet
Range("A1").Select
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlDown)).Select
ws.Sort.SortFields.Clear
ws.Sort.SortFields.Add2 Key:=Range("H2:H2500" _
), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With ws.Sort
.SetRange Range("A1:H2500")
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Range("I2").Select
ActiveCell.FormulaR1C1 = _
"=IF(OR(RIGHT(RC[-8],2) = ""SJ"", RIGHT(RC[-8],2) = ""LN"", RIGHT(RC[-8],2) = ""IT"", RIGHT(RC[-8],2) = ""KK""),IF(RIGHT(RC[-8],2) = ""KK"",RC[-2]/1000,RC[-2]/100),RC[-2])"
Range("I2").Select
Selection.Copy
Selection.End(xlToLeft).Select
Selection.End(xlDown).Select
Range("I2500").Select
Range(Selection, Selection.End(xlUp)).Select
Range("I3:I2500").Select
Range("I2500").Activate
ActiveSheet.Paste
Selection.End(xlUp).Select
Range(Selection, Selection.End(xlDown)).Select
Application.CutCopyMode = False
Selection.Copy
Range("G2").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Selection.NumberFormat = "0.0000"
Columns("I").Delete
Dim strDataRange As Range
Dim keyRange As Range
Set strDataRange = Range("A:H")
Set keyRange = Range("C1")
strDataRange.Sort Key1:=keyRange, Header:=xlYes
Rows(1).Delete
End sub
Sample Input Data
Codes
Population
Animal
Type
Size
Housing Qty
Average Cost
Country
SHIB IT
4,504
DOGE
Standard
SMALL
15,019
9.5557
JP
CORG LN
33,052
DOGE
Standard
SMALL
8,816
31,404.9100
FR
SOG SJ
1,417
CAT
Standard
BIG
90
247.2508
ZM
CHOW KK
873
DOGE
Standard
BIG
9,192
177.2797
CN
FLOP AG
991
CAT
Standard
BIG
7
597.0650
BZ
Desired Output Data:
Please, try the next compact and fast code. It will place the range to be processed in an array and drop down the processed result at the end. Now it returns overwriting the existing range. It can be easily adapted to return in another sheet:
Sub processRangeAH()
Dim sh As Worksheet, lastR As Long, rng As Range, arr, i As Long
Set sh = ActiveSheet
lastR = sh.Range("A" & sh.rows.count).End(xlUp).row
Set rng = sh.Range("A1:H" & lastR)
rng.Sort Key1:=sh.Range("H1"), Order1:=xlAscending, Header:=xlYes
arr = rng.Value2
For i = 2 To UBound(arr)
Select Case UCase(Right(arr(i, 1), 2))
Case "IT", "LN", "SJ": arr(i, 7) = arr(i, 7) / 100
Case "KK": arr(i, 7) = arr(i, 7) / 1000
End Select
Next i
rng.Value2 = arr
rng.Sort Key1:=sh.Range("C1"), Order1:=xlAscending, Header:=xlYes
sh.Range("G2:G" & lastR).NumberFormat = "0.0000"
sh.rows(1).Delete
End Sub
I posted this answer some hours before, when I left my office, but by mistake, in another thread...
Just to see how an array can be used, in order to increase the speed for larger range.
Try this. It copies everything to a new sheet so you don't lose the original data. Could be sped up if you have lots of data.
Sub x()
Dim ws As Worksheet, r As Long
Set ws = Worksheets.Add
Sheet1.Range("A1").CurrentRegion.Copy ws.Range("A1") 'assumes data on sheet1 (code name, change to suit)
For r = 2 To ws.Range("A" & Rows.Count).End(xlUp).Row
Select Case Right(ws.Cells(r, 1), 2)
Case "IT", "LN", "SJ": ws.Cells(r, "G").Value = ws.Cells(r, "G").Value / 100
Case "KK": ws.Cells(r, "G").Value = ws.Cells(r, "G").Value / 1000
End Select
Next r
With ws.Sort
.SortFields.Clear
.SortFields.Add2 Key:=ws.Range("C2:C" & ws.Range("A" & Rows.Count).End(xlUp).Row), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
.SortFields.Add2 Key:=Range("H2:H" & ws.Range("A" & Rows.Count).End(xlUp).Row), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
.SetRange Range("A1:H" & ws.Range("A" & Rows.Count).End(xlUp).Row)
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
End Sub
I was reading the following post and tried to copy the first 20 rows (exclude header) from the filtered table. However, the last line gave me an error. What did I do wrong here ?
Sub Macro1()
'
' Macro1 Macro
'
'
Dim wb As Workbook
Dim ws As Worksheet
Set wb = ActiveWorkbook
Set ws = ThisWorkbook.Sheets("HelloWorld")
wb.Activate
ws.Activate
ws.AutoFilterMode = False
If ws.Range("A1:L11470").AutoFilter Then
ws.Range("A1:L11470").AutoFilter
End If
ws.Range("A1:L11470").AutoFilter
ws.AutoFilter.Sort.SortFields.Add2 Key:=Range("G1:G11470"), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
With ws.AutoFilter.Sort
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
ws.Range("$A$1:$L$11470").AutoFilter Field:=11, Criteria1:="<>-"
ws.Range("$A$1:$L$11470").AutoFilter Field:=1, Criteria1:="10", Operator:=xlTop10Items ' <-- Error here
End Sub
The error is as follow:
I think I would take a slightly different approach to achieve the end you seem to be looking for. The code suggested below does the following based on my interpretation of your question:
Sort the data range A:L on the sheet “HelloWorld” by column G
Set a filter such that column A = 10 and column K <> “-“
Counts the first 20 filtered (visible) rows on the HelloWorld sheet and copies them (in this demonstration to Sheet2)
If this isn’t exactly what you were looking for, please comment & I’ll adjust accordingly.
Option Explicit
Sub TestTop20()
Dim ws As Worksheet, c As Range, i As Integer, LastRow As Long, EndData As Long
Set ws = ThisWorkbook.Sheets("HelloWorld")
'Determine the last 'possible' row of data
LastRow = ws.Cells(Rows.Count, 1).End(xlUp).Row
'Sort your data on column G
ws.Columns("A:L").Sort _
Key1:=ws.Range("G2"), order1:=xlDescending, Header:=xlYes
'Set the filter on columns K & A
With ws.Range("A1")
.AutoFilter
.AutoFilter Field:=1, Criteria1:="=10"
.AutoFilter Field:=11, Criteria1:="<>-"
End With
'Determine what the last visible row is - up to 20
i = 0
For Each c In ws.Range("A2:A" & LastRow)
If c.EntireRow.Hidden = False Then
i = i + 1
If i = 20 Then
EndData = c.Row
Exit For
End If
End If
Next c
If EndData < 20 Then MsgBox "Less than 20 records were detected"
'Copy the first 20 filtered records
ws.Range("A2:A" & EndData).SpecialCells(xlCellTypeVisible) _
.EntireRow.Copy Sheet2.Range("A1")
ws.AutoFilterMode = False
Application.Goto ws.Range("A1")
End Sub
I have a named range that looks like:
For each row where column 2 equals zero I want to white out the row from columns A:F (the six columns). What I have does not work as it selects the entire named range and whites the whole thing out when the if statement becomes true.
Sub modFinishFinancialEstimate()
Dim myrange As Range
Dim ws As Worksheet
Set myrange = Range("actual_cost_of_svc")
Set ws = ActiveSheet
ws.Select
For i = myrange.Rows(1).row To myrange.Rows.Count
MsgBox "The Count of services is " & Cells(i, 2).Value
If Range("B" & i).Value = 0 Then
MsgBox "The value is " & Cells(i, 2).Value & " and will be whited out"
For Each col In myrange.Columns
With Selection.Font
.ThemeColor = xlThemeColorDark1
.TintAndShade = 0
End With
ActiveWorkbook.ws.Sort.SortFields.Add Key:=Range( _
myrange), SortOn:=xlSortOnCellColor, Order:=xlAscending, DataOption:= _
xlSortNormal
With Selection.Sort
.SetRange myrange
.Header = xlGuess
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Next col
End If
Next
End Sub
The problem I encounter with the code above is that it checks the first row only and then exits the sub.
The first row will be
msgbox myrange.rows(1).row
You don't need to Select anything.
Alternatively, you could make your loop relative, i.e. the ith cell of myrange rather than the ith cell of the worksheet.
I have a list of networks with each one containing various rows (e.g., network A has 4 rows or 4 instances). I want to be able to sort the data in 'blocks' or segment it in a way where I can easily view aggregates or manipulate the data for each Network.
I want to segment the data via VBA/macro that does this automatically, with the final row for each Network calculating a given metric.
The data, of course, can be filtered this way via the 'filter' option and manually worked on. I'm looking to automate this process via VBA/Macros, can anyone point me towards the right direction or help?
Thanks!
Based on how I interpreted what you wanted to do, this is where I'd start:
pt. 1: find the range for data a particular column
Dim col_var, first_row, last_row, i As Long, myrang As String
i = 1
'find first & last row of data
col_var = ActiveCell.Column
While Cells(i, col_var) = 0
i = i + 1
Wend
first_row = i
While Cells(i, col_var) <> 0
i = i + 1
Wend
last_row = i
'set range
myrang = Cells(first_row, col_var).Address & ":" & Cells(last_row, col_var).Address
pt. 2: Then you can just "record macro" to find how to use the filter, and then replace the important bits with "myrang":
ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Add Key:=Range(Cells(first_row, col_var).Address), _
SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("Sheet1").Sort
.SetRange Range(myrang)
.Header = xlNo
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
This, at the moment, sorts a column picked by which is the "active column" on the time of starting the macro (i.e. which column you had most recently clicked on before starting the macro). This is found by the line:
col_var = ActiveCell.Column
however, this could be changed so that it can be:
pt. 3: iterated across for a number of columns, by saying
col_var = j
and then you can put everything written so far in something that loops j (here I've gone from columns 4 - 8 but you can change this easily to what you want):
Sub sorting()
Dim col_var, first_row, last_row, i As Long, myrang As String
for j = 4 to 8
i = 1
'find first & last row of data
col_var = j
While Cells(i, col_var) = 0
i = i + 1
Wend
first_row = i
While Cells(i, col_var) <> 0
i = i + 1
Wend
last_row = i
'set range
myrang = Cells(first_row, col_var).Address & ":" & Cells(last_row, col_var).Address
ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Add Key:=Range(Cells(first_row, col_var).Address), _
SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("Sheet1").Sort
.SetRange Range(myrang)
.Header = xlNo
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
next j
End Sub
I've tried various solutions that I've found online, but with no luck yet. Here is my VBA code to copy cells from about 30 sheets and paste them all onto one sheet. Each sheet has Formulas in 4 columns that show a value if there is a value in another sheet. Like this:
=IF(Sheet1!A2<>"", Sheet1!A2, "")
Then I run my macro on the page that I want it to output:
Sub SummurizeSheets()
Dim ws As Worksheet
Application.ScreenUpdating = False
Sheets("Summary").Activate
For Each ws In Worksheets
If ws.Name <> "Summary" And ws.Name <> "Sheet1" Then
ws.Range("A2:D5406").Copy
Worksheets("Summary").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).PasteSpecial (xlPasteValues), SkipBlanks:=True
End If
Next ws
End Sub
The output results in a lot of blank cells after the ones with actual values in them.
I tried putting that "SkipBlanks" variant in there, but that wasn't the solution. Any help would be appreciated.
This was answered for me on excelforum.com, co I figured I'd post the solution here in case it helps anyone else.
Sub SummurizeSheets()
Dim ws As Worksheet
Application.ScreenUpdating = False
Sheets("Summary").Activate
For Each ws In Worksheets
If ws.Name <> "Summary" And ws.Name <> "Sheet1" Then
ws.Range("A2:D5406").Copy
Worksheets("Summary").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlPasteValues, SkipBlanks:=False
End If
Next ws
'Try inserting this line
'***********************************************************************
Worksheets("Summary").Select
'************************************************************************
'Find the last used row in column 1
LR = Cells(Rows.Count, 1).End(xlUp).Row
'Insert a formula in column E to return the row number of any non blank row
Range("E1:E" & LR).FormulaR1C1 = "=IF(RC[-4]="""","""",ROW())"
'Copy Paste Values to remove the formula
Range("E1:E" & LR).Value = Range("E1:E" & LR).Value
'Sort your data
ActiveWorkbook.Worksheets("Summary").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("Summary").Sort.SortFields.Add Key:=Range("E1:E" & LR) _
, SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("Summary").Sort
.SetRange Range("A1:E" & LR)
.Header = xlGuess
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
'Clear Column E
Range("E1:E" & LR).ClearContents
Range("A1").Select
End Sub