Below is the VBA macro which I have made. It will filter on the names column and find the empty cells and from another sheet.
It is supposed to find the names of phone numbers and paste it there.
I want this for empty cells only but this code is working for every row.
How can I find the values for visible cells only?
Sub namenumbers()
On Error Resume Next
rw = ActiveWorkbook.Name
MP = InputBox("Please enter Marketplace", "AU/AE/BR/CA/CN/DE/ES/FR/IT/UK/US/IN/JP/MX/SG/TR")
Dim wb As Worksheet, rng As Range
lrr = ActiveSheet.UsedRange.Rows.Count
Set r = Range("A1").CurrentRegion
r.AutoFilter
BN = r.Find(what:="Numbers", after:=r(1)).Column
Kolumn = r.Find(what:="names", after:=r(1)).Column
r.AutoFilter Field:=Kolumn, Criteria1:="="
Workbooks.Open "C:\Macros\names with numbers.xlsx"
nw = ActiveWorkbook.Name
Workbooks(nw).Activate
Workbooks(nw).Sheets(MP).Activate
Workbooks(rw).Activate
For I = 3 To lrr
Cells(I, Kolumn) = Application.WorksheetFunction.VLookup(Cells(I, BN), Workbooks(nw).Sheets(MP).Range("B2:D1000000"), 3, 0)
Next
End Sub
You can try something like this:
Sub namenumbers()
Dim wb As Workbook, MP, lrr As Long, wsData As Workbook, i As Long
Dim ws As Worksheet, rng As Range, r As Range, BN As Long, Kolumn As Long
On Error Resume Next
Set wb = ActiveWorkbook
Set ws = ActiveSheet
MP = InputBox("Please enter Marketplace", _
"AU/AE/BR/CA/CN/DE/ES/FR/IT/UK/US/IN/JP/MX/SG/TR")
Set r = ws.Range("A1").CurrentRegion
lrr = r.Rows.Count
BN = r.Rows(1).Find(what:="Numbers", lookat:=xlWhole).Column
Kolumn = r.Rows(1).Find(what:="names", lookat:=xlWhole).Column
Set wsData = Workbooks.Open("C:\Macros\names with numbers.xlsx").Worksheets(MP)
For i = 3 To lrr
With ws.Cells(i, Kolumn)
If Len(.Value) = 0 Then
.Value = Application.VLookup(ws.Cells(i, BN).Value, _
wsData.Range("B2:D1000000"), 3, False)
End If
End With
Next
End Sub
Related
I have a worksheet with sales data, I've managed to create Autofilter based on department and copied the results into the new sheet (Output). What I'm trying to achieve is that code will multiply the results of respective month by value in "Adjustment" row.
So the result is following
Is there a way how to process calculations within my code or I shall multiply each column in different Sub afterwards?
Dim Last_Row As Long
Dim DbExtract, DuplicateRecords As Worksheet
Dim WKS2 As Worksheet
Dim rn As Range
Set DbExtract = ThisWorkbook.Sheets("Data")
Set DuplicateRecords = ThisWorkbook.Sheets("Output")
Set WKS2 = ThisWorkbook.Sheets("Dashboard")
iMultiplier = WKS2.Range("Z18")
Application.ScreenUpdating = False
Last_Row = DuplicateRecords.Range("A" & Rows.Count).End(xlUp).Row + 1
DbExtract.Range("C3:R1500").SpecialCells(xlCellTypeVisible).Copy
DuplicateRecords.Range("A" & Last_Row).PasteSpecial
DuplicateRecords.Range("$A$1:$P$400").AutoFilter Field:=3, Criteria1:=WKS2.Range("V2")
Set rn = DuplicateRecords.Range("G2:G500").SpecialCells(xlCellTypeVisible)
For Each cell In rn
iNewnumber = cell * iMultiplier
Next cell
End Sub
Here's an example:
Sub Tester()
Dim lastRow As Long, wb As Workbook
Dim wsData As Worksheet, wsOutput As Worksheet
Dim wsDash As Worksheet, rngVis As Range, numVisRows As Long
Dim rn As Range, rngAdj As Range, m As Long, adj, c As Range
Set wb = ThisWorkbook
Set wsData = wb.Sheets("Data") 'consistent naming helps...
Set wsOutput = wb.Sheets("Output")
Set wsDash = wb.Sheets("Dashboard")
'iMultiplier = wsDash.Range("Z18") '?
Application.ScreenUpdating = False
Set rngVis = wsData.Range("C3:R1500").SpecialCells(xlCellTypeVisible)
numVisRows = rngVis.Cells.Count / rngVis.Columns.Count
rngVis.Copy
lastRow = wsOutput.Range("A" & Rows.Count).End(xlUp).Row + 1 'start of pasted data
wsOutput.Range("A" & lastRow).PasteSpecial
Set rngAdj = wsDash.Range("C5:N5") 'for example
For m = 1 To rngAdj.Columns.Count 'loop the cells in the adjustments range
adj = rngAdj.Cells(m).Value 'adjustment value
If Len(adj) > 0 And IsNumeric(adj) Then 'have an adjustment to make?
'loop the relevant cells in the pasted data
For Each c In wsOutput.Cells(lastRow, "A").Offset(0, 2 + m).Resize(numVisRows).Cells
If Len(c.Value) > 0 And IsNumeric(c.Value) Then 'any thing to adjust?
c.Value = c.Value * adj
End If
Next c
End If
Next m
End Sub
I am looking to consolidate data from multiple worksheets and Workbooks with different column headers into single worksheet name (Database) using vba. Currently I have the below code that opens two workbooks and copies the sheets to the destination workbook. Then currently (Database sheet) in the destination workbook has fixed headers which are then matched with headers in all the copied sheets and then copies all the row data and pastes into Database sheet for the respective column header.
Sub CopySheetFromClosedWB()
Application.ScreenUpdating = False
Dim closedBook1 As Workbook
Dim closedBook2 As Workbook
Set closedBook1 = Workbooks.Open("C:\New folder\Exec_072021.xlsb", Password:="**********")
Set closedBook2 = Workbooks.Open("C:\New folder\Non Exec_072021.xlsb", Password:="**********")
Dim ws1 As Worksheet
For Each ws1 In closedBook1.Sheets
ws1.Copy After:=ThisWorkbook.Sheets(3)
ActiveSheet.Name = ActiveSheet.Name & "_Exec"
If ActiveSheet.AutoFilterMode Then
ActiveSheet.AutoFilterMode = False
End If
Next ws1
closedBook1.Close SaveChanges:=False
Dim ws2 As Worksheet
For Each ws2 In closedBook2.Sheets
ws2.Copy After:=ThisWorkbook.Sheets(3)
ActiveSheet.Name = ActiveSheet.Name & "_NonExec"
If ActiveSheet.AutoFilterMode Then
ActiveSheet.AutoFilterMode = False
End If
Next ws2
closedBook2.Close SaveChanges:=False
Call UpDateData
MsgBox "Database Created!!"
Application.ScreenUpdating = True
End Sub
Sub UpDateData()
Application.ScreenUpdating = False
Dim i As Long, j As Long, k As Long, n As Long, wData As Worksheet, _
Process(1 To 10) As String, iProc As Long, Dict As Object
Process(1) = "Manila_Exec"
Process(2) = "Cebu_Exec"
Process(3) = "Davao_Exec"
Process(4) = "CDO_Exec"
Process(5) = "Bacolod_Exec"
Process(6) = "Manila_NonExec"
Process(7) = "Cebu_NonExec"
Process(8) = "Davao_NonExec"
Process(9) = "CDO_NonExec"
Process(10) = "Bacolod_NonExec"
Set wData = Sheets("Database")
Set Dict = CreateObject("Scripting.Dictionary")
With wData
.UsedRange.Offset(1).Clear
For j = 1 To .Cells(1, .Columns.Count).End(xlToLeft).Column
If Len(.Cells(1, j)) > 0 Then Dict.Add LCase$(.Cells(1, j)), j
Next j
End With
i = 2
For iProc = 1 To 10
With Sheets(Process(iProc))
n = .Cells(.Rows.Count, 1).End(xlUp).Row
For j = 1 To .Cells(1, .Columns.Count).End(xlToLeft).Column
If Dict.exists(LCase$(.Cells(1, j))) Then
k = Dict(LCase$(.Cells(1, j)))
.Cells(2, j).Resize(n - 1).Copy wData.Cells(i, k).Resize(n - 1)
End If
Next j
End With
i = i + n - 1
Next iProc
Sheets("Database").Select
Selection.CurrentRegion.Select
Selection.CurrentRegion.Font.Size = 9
Selection.CurrentRegion.Font.Name = "Calibri"
Selection.CurrentRegion.Borders.LineStyle = x1None
For x = 1 To ActiveSheet.UsedRange.Columns.Count
Columns(x).EntireColumn.AutoFit
Next x
End Sub
I am trying to make a code that can eliminate the dependency of moving the sheets from multiple workbooks to destination workbook and copy values along with header names for all the matched and unmatched column headers.
Headers are in row 1 in all the worksheets.
Total rows - 50000+
Total columns - 170+
Tested, and working for me.
EDIT: made a bunch of fixes.
Sub ProcessWorkbooks()
Dim f, wsData As Worksheet, wbSrc As Workbook, map As Object
Set wsData = ThisWorkbook.Sheets("Data")
wsData.UsedRange.ClearContents 'clear any existing data
Set wbSrc = Workbooks.Open("C:\New folder\Exec_072021.xlsb", Password:="**********")
ImportData wbSrc, wsData
wbSrc.Close False
Set wbSrc = Workbooks.Open("C:\New folder\Non Exec_072021.xlsb", Password:="**********")
ImportData wbSrc, wsData
wbSrc.Close False
With wsData.Range("A1").CurrentRegion
.Font.Size = 9
.Font.Name = "Calibri"
.Borders.LineStyle = xlLineStyleNone
.EntireColumn.AutoFit
End With
End Sub
Sub ImportData(wbIn As Workbook, wsData As Worksheet)
Dim lrData As Long, lrSrc As Long, ws As Worksheet, c As Range
Dim Process, hdr, m
Process = Array("Manila", "Cebu", "Davao", "CDO", "Bacolod")
Application.ScreenUpdating = False
For Each ws In wbIn.Worksheets
If Not IsError(Application.Match(ws.Name, Process, 0)) Then 'process this sheet?
lrData = SheetLastRow(wsData) + 1
If lrData = 1 Then lrData = 2 'in case no headers yet...
lrSrc = SheetLastRow(ws)
For Each c In ws.Range("A1", ws.Cells(1, Columns.Count).End(xlToLeft)).Cells
hdr = c.Value
m = Application.Match(hdr, wsData.Rows(1), 0) 'existing column match?
If IsError(m) Then
m = Application.CountA(wsData.Rows(1))
m = IIf(m = 0, 1, m + 1)
wsData.Cells(1, m).Value = hdr 'add as new column header
End If
ws.Range(c.Offset(1), ws.Cells(lrSrc, c.Column)).Copy _
wsData.Cells(lrData, m)
Next c
End If
Next ws
End Sub
'return the last used row in a worksheet
Function SheetLastRow(ws As Worksheet) As Long
Dim f As Range
Set f = ws.Cells.Find("*", ws.Range("A1"), xlFormulas, xlPart, xlByRows, xlPrevious)
If Not f Is Nothing Then SheetLastRow = f.Row 'otherwise 0
End Function
I have data in a table, where I compare two columns J and T. The values which J and T can take include A2B, APL, BGF, CMA, among others (see code).
If these values are equal, copy row i into the sheet which has the name of the cells just checked.
If these values are not equal, copy row i into the sheets which have the name of the cells just checked.
Example: Compare J2 and T2,
Suppose J2=T2=BGF then copy row 2 and paste into sheet("BGF")
Next, compare J3 and T3
Suppose J3=BGF and T3=CMA, copy row 3 and paste into sheet(BGF) and sheet(CMA)
Next, compare J4 and T4
Suppose J4=Nothing and T4=CMA, copy row 4 and paste into sheet CMA
the only other combination is where Ji has a value and Ti is empty.
Problem: When running this code, If J3=BGF and T3= nothing (its empty), then the line is not copied to any sheet.
Here's the code
Sub Sortdata()
'step 1 clear all data
Sheets("A2B").Cells.ClearContents
Sheets("APL").Cells.ClearContents
Sheets("BGF").Cells.ClearContents
Sheets("CMA").Cells.ClearContents
Sheets("K Line").Cells.ClearContents
Sheets("MacAndrews").Cells.ClearContents
Sheets("Maersk").Cells.ClearContents
Sheets("OOCL").Cells.ClearContents
Sheets("OPDR").Cells.ClearContents
Sheets("Samskip").Cells.ClearContents
Sheets("Unifeeder").Cells.ClearContents
Dim i As Long
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim LastRow As Long
With Worksheets("All Data")
LastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
For i = 2 To LastRow
If IsEmpty(.Range("J" & i)) Then
Set ws1 = Nothing
Else
Set ws1 = Worksheets(.Range("J" & i).Value)
End If
If IsEmpty(.Range("T" & i)) Then
Set ws2 = Nothing
Else
Set ws2 = Worksheets(.Range("T" & i).Value)
End If
If ws1 Is Nothing Then
If Not ws2 Is Nothing Then
CopyToWs ws2, .Rows(i)
End If
ElseIf ws2 Is Nothing Then
If Not ws1 Is Nothing Then
CopyToWs ws1, .Rows(i)
End If
Else
CopyToWs ws1, Rows(i)
If ws1.Name <> ws2.Name Then
CopyToWs ws2, .Rows(i)
End If
End If
Next
End With
End Sub
Sub CopyToWs(ws As Worksheet, rng As Range)
rng.Copy
ws.Cells(ws.Rows.Count, 1).End(xlUp).Offset(1, 0).EntireRow.PasteSpecial xlPasteValuesAndNumberFormats
End Sub
Please try this code. It takes a slightly different approach to what you tried but it gets the job done, I think.
Option Explicit
Sub Sortdata()
' Variatus #STO 20 Jan 2020
Const WsNames As String = "A2B,APL,BGF,CMA,K Line,MacAndrews," & _
"Maersk,OOCL,OPDR,Samskip,Unifeeder"
Dim WsS As Worksheet ' Source
Dim Ws As Worksheet
Dim Rng As Range
Dim Rt As Long ' target row
Dim LastRow As Long
Dim J As Long, T As Long
Dim Tmp As Variant, PrevTmp As Variant
Dim R As Long, C As Long
'step 1 clear all data
Tmp = Split(WsNames, ",")
For R = LBound(Tmp) To UBound(Tmp)
On Error Resume Next
Worksheets(Tmp(R)).Cells.ClearContents
Next R
Application.ScreenUpdating = False
Set WsS = Worksheets("All Data")
With WsS
J = .Columns("J").Column
T = .Columns("T").Column
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
For R = 2 To LastRow
PrevTmp = ""
For C = J To T Step T - J
Tmp = .Cells(R, C).Value
If Len(Tmp) And Tmp <> PrevTmp Then
On Error Resume Next
Set Ws = Worksheets(Tmp)
If Err = 0 Then
Set Rng = .Range(.Cells(R, 1), .Cells(R, .Columns.Count).End(xlToLeft))
With Ws
Rt = Application.Max(.Cells(.Rows.Count, "A").End(xlUp).Row + 1, 2)
Rng.Copy Destination:=Ws.Cells(Rt, 1)
End With
End If
End If
PrevTmp = Tmp
Next C
If R Mod 25 = 0 Then Application.StatusBar = "Currently processing row " & R
Next R
End With
With Application
.ScreenUpdating = True
.StatusBar = "Done"
End With
End Sub
I think you will be able to find your way through it and make any required modifications. Let me know if you require any assistance.
This code gives me everything from all the sheets and not even in a way that columns are matched up. I made a VBA script the took all 127 individual excell sheets and combined them into one workbook with 600+ sheets. I want only the 127 sheets called "Function Dependency" numbered blank - 127 to be combined into one sheet. The columns sometimes have useless data in the first row but otherwise have similar columns. Is there a better way to do this??
Sub MergeAll()
Dim r As Long, ws As Worksheet, rAll As Long, wsAll As Worksheet
Dim i As Long
Worksheets.Add After:=Worksheets(Worksheets.Count)
ActiveSheet.name = "All"
Set wsAll = ActiveSheet
rAll = 2
For Each ws In Worksheets
If ws.name <> "All" Then
r = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
For i = 1 To r
wsAll.Cells(rAll, 1) = ws.name
wsAll.Cells(rAll, 2) = ws.Cells(i, 1)
wsAll.Cells(rAll, 3) = ws.Cells(i, 2)
rAll = rAll + 1
Next i
End If
Next ws
End Sub
Sub MergeAll()
Dim r As Long, ws As Worksheet, rAll As Long, wsAll As Worksheet
Dim i As Long, wb As Workbook
Set wb = ThisWorkbook
Set wsAll = wb.Worksheets.Add(After:=wb.Worksheets(wb.Worksheets.Count))
wsAll.name = "All"
rAll = 2
For Each ws In Worksheets
If ws.name Like "Function Dependency*" Then
r = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
For i = 1 To r
wsAll.Cells(rAll, 1).Resize(1, 3).value = _
Array(ws.name, ws.Cells(i, 1), ws.Cells(i, 2))
rAll = rAll + 1
Next i
End If
Next ws
End Sub
I may have up to 8 unique values in column D. I am looking for a code that will copy & paste each row with unique value to a new sheet.
So I may have up to 8 new sheets.
Could you help me to build the code that will do that?
This is what I have so far:
Option Explicit
Sub AddInstructorSheets()
Dim LastRow As Long, r As Long, iName As String
Dim wb As Workbook, ws As Worksheet, ts As Worksheet, nws As Worksheet
Dim i As Integer
Dim m As Integer
'set objects
Set wb = ActiveWorkbook
Set ws = ActiveSheet
Set ts = Sheets("Master")
'set last row of instructor names
LastRow = ws.Cells(ws.Rows.Count, "K").End(xlUp).Row
'add instructor sheets
On Error GoTo err
Application.ScreenUpdating = False
For r = 17 To LastRow 'assumes there is a header
iName = ws.Cells(r, 4).Value
With wb 'add new sheet
ts.Copy After:=.Sheets(.Sheets.Count) 'add template
Set nws = .Sheets(.Sheets.Count)
nws.Name = iName
Worksheets(iName).Rows("17:22").Delete
Worksheets("Master").Activate
Range(Cells(r, 2), Cells(r, 16)).Select
Selection.Copy
m = Worksheets(iName).Range("A15").End(xlDown).Row
Worksheets(iName).Cells(m + 1, 1).PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
End With
Next r
err:
ws.Activate
Application.ScreenUpdating = True
End Sub
The thing is that this macro is creating new sheets, which is not necessary. I only want to make following.
If you find a unique value in column D (which will have exact name as other sheet), find this sheet and paste whole row in there.
Sub CopyFromColumnD()
Dim key As Variant
Dim obj As Object
Dim i As Integer, lng As Long, j As Long
Dim sht As Worksheet, mainsht As Worksheet
Set obj = CreateObject("System.Collections.ArrayList")
Set mainsht = ActiveSheet
With mainsht
lng = .Range("D" & .Rows.Count).End(xlUp).Row
With .Range("D1", .Range("D" & lng))
For Each key In .Value
If Not obj.Contains(key) Then obj.Add key
Next
End With
End With
For i = 0 To obj.Count - 1
Set sht = Sheets.Add(After:=Sheets(Sheets.Count))
sht.Name = obj(i)
For j = 1 To lng
If mainsht.Cells(j, 4).Value = obj(i) Then
mainsht.Rows(j).EntireRow.Copy Destination:=Range("A1")
Exit For
End If
Next
Next
End Sub
Ok, I did the workaround. I have created a list of unique values in a separate sheet.
Sub copypaste()
Dim i As Integer
Dim j As Integer
LastRow = Worksheets("Master").Range("D17").End(xlDown).Row
For i = 17 To LastRow
For j = 2 To 10
Workstream = Worksheets("Database").Cells(j, 5).Value
Worksheets("Master").Activate
If Cells(i, 4) = Worksheets("Database").Cells(j, 5).Value Then
Range(Cells(i, 2), Cells(i, 16)).Select
Selection.Copy
Worksheets(Workstream).Cells(1, 1).PasteSpecial Paste:=xlPasteValues
Else
End If
Next j
Next i
End Sub
Thank you everyone for help and your time!